(**************************************************************************)
(*  This is part of STATES, it is distributed under the terms of the      *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms.
Set Implicit Arguments.
Require Import ZArith.
Open Scope Z_scope.
Require Import Bool.

Module Make(Import M: Memory.T).
  Module Export DecorationsExp := Terms.Make(M).

 Inductive kind  := pure  | ro  | rw.
 Inductive ekind := epure | ppg | ctc.

 Inductive is   : ((kind * ekind)%type) -> forall X Y, term X Y -> Prop :=
  | is_tpure    : forall X Y (f: X -> Y), is (pure, epure) (@tpure X Y f)
  | is_comp     : forall k X Y Z (f: term X Y) (g: term Y Z), is k f -> is k g -> is k (f o g)
  | is_pair     : forall k1 k2 X Y Z (f: term X Z) (g: term Y Z), is (ro,  k2) f -> is (k1, k2) f -> is (k1, k2) g -> is (k1, k2) (pair f g)    (* FIXED *)
  | is_copair   : forall k1 k2 X Y Z (f: term Z X) (g: term Z Y), is (k1, ppg) f -> is (k1, k2) f -> is (k1, k2) g -> is (k1, k2) (copair f g)  (* FIXED *)
  | is_downcast : forall X Y (f: term X Y), is (pure, ppg) (@downcast X Y f)
  | is_lookup   : forall i, is (ro, epure) (lookup i)
  | is_update   : forall i, is (rw, epure) (update i)
  | is_tag      : forall e, is (pure, ppg) (tag e)
  | is_untag    : forall e, is (pure, ctc) (untag e)
  | is_pure_ro  : forall X Y k (f: term X Y), is (pure, k) f -> is (ro, k) f
  | is_ro_rw    : forall X Y k (f: term X Y), is (ro, k) f -> is (rw, k) f
  | is_pure_ppg : forall X Y k (f: term X Y), is (k, epure) f -> is (k, ppg) f
  | is_ppg_ctc  : forall X Y k (f: term X Y), is (k, ppg) f -> is (k, ctc) f.

 Hint Constructors is.

 Ltac decorate :=  solve[
                          repeat (apply is_comp || apply is_pair  || apply is_copair)
                            ||
		                 (apply is_tpure    || apply is_lookup || apply is_update ||
	                          apply is_downcast || apply is_tag    || apply is_untag  || assumption)

			    ||
                                 (apply is_pure_ro)
			    ||
		                 (apply is_ro_rw)
			    ||
                                 (apply is_pure_ppg)
			    ||
                                 (apply is_ppg_ctc)
                        ].

 Ltac edecorate :=  solve[
                          repeat (apply is_comp || apply is_pair || apply is_copair)
                            ||
		                 (apply is_tpure    || apply is_lookup || apply is_update ||
	                          apply is_downcast || apply is_tag    || apply is_untag  || assumption)
			    ||
                                 (apply is_pure_ppg)
			    ||
                                 (apply is_ppg_ctc)
                           ||
                                 (apply is_pure_ro)
			    ||
		                 (apply is_ro_rw)
                        ].

Definition dmax (k1 k2: kind): kind :=
  match k1, k2 with
    | pure, pure => pure
    | pure, ro  => ro
    | pure, rw  => rw
    | ro, pure  => ro
    | rw, pure => rw
    | ro, ro   => ro
    | ro, rw   => rw
    | rw, ro   => rw
    | rw, rw   => rw
  end.

Definition edmax (k1 k2: ekind): ekind :=
  match k1, k2 with
    | epure, epure => epure
    | epure, ppg  => ppg
    | epure, ctc  => ctc
    | ppg, epure  => ppg
    | ctc, epure => ctc
    | ppg, ppg   => ppg
    | ppg, ctc   => ctc
    | ctc, ppg   => ctc
    | ctc, ctc   => ctc
  end.

Lemma _is_comp: forall k1 k2 k3 k4 X Y Z (f: term X Y) (g: term Y Z), is (k1, k3) f -> is (k2, k4) g -> is ((dmax k1 k2), (edmax k3 k4)) (f o g).
Proof. intros.
       case_eq k1; case_eq k2; case_eq k3; case_eq k4; cbn; intros; subst; try edecorate; try decorate;
       apply is_comp; try (decorate || edecorate); apply is_ro_rw; apply is_ppg_ctc; easy.
Qed.

Lemma _is_pair: forall k1 k2 k3 k4 X Y Z (f: term X Z) (g: term Y Z),
is (ro,  k4) f -> is (k1, k3) f -> is (k2, k4) g -> is ((dmax k1 k2), (edmax k3 k4)) (pair f g).
Proof. intros.
       case_eq k1; case_eq k2; case_eq k3; case_eq k4; cbn; intros; subst; try edecorate; try decorate;
       apply is_pair; try (decorate || edecorate); apply is_ro_rw; apply is_ppg_ctc; easy.
Qed.

Lemma _is_copair: forall k1 k2 k3 k4 X Y Z (f: term Z X) (g: term Z Y),
is (k1,  ppg) f -> is (k1, k3) f -> is (k2, k4) g -> is ((dmax k1 k2), (edmax k3 k4)) (copair f g).
Proof. intros.
       case_eq k1; case_eq k2; case_eq k3; case_eq k4; cbn; intros; subst; try edecorate; try decorate;
       apply is_copair; try (decorate || edecorate); apply is_ro_rw; apply is_ppg_ctc; easy.
Qed.

 Class PURE {A B: Type} (k: ekind) (f: term A B) := ispr : is (pure, k) f.
 Hint Extern 0 (PURE _)        => decorate : typeclass_instances.

 Class RO {A B: Type} (k: ekind) (f: term A B) := isro : is (ro, k) f.
 Hint Extern 0 (RO _)          => decorate : typeclass_instances.

 Class RW {A B: Type} (k: ekind) (f: term A B) := isrw : is (rw, k) f.
 Hint Extern 0 (RW _)          => decorate : typeclass_instances.

 Class EPURE {A B: Type} (k: kind) (f: term A B) := isepr : is (k, epure) f.
 Hint Extern 0 (EPURE _)       => edecorate : typeclass_instances.

 Class PPG {A B: Type} (k: kind) (f: term A B) := isthrw : is (k, ppg) f.
 Hint Extern 0 (PPG _)  => edecorate : typeclass_instances.

 Class CTC {A B: Type} (k: kind) (f: term A B) := isctch : is (k, ctc) f.
 Hint Extern 0 (CTC _)     => edecorate : typeclass_instances.

End Make.


Generalizable All Variables.
Set Implicit Arguments.

Require Import
        Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Fiat.Common.ilist
        Fiat.Common.ilist2.

Section i2list2.

(* Lists of elements whose types depend on a pairs of indexing set
     (CPDT's hlists). *)

  Variable A : Type. (* The indexing type. *)
  Variable B B' : A -> Type. (* The type of indexed elements. *)
  Variable C : forall a, B a -> B' a -> Type. (* The type of doubly-indexed elements. *)

  Record prim_prod_3 A B C :=
    { prim_3_fst : A;
      prim_3_snd : B;
      prim_3_thd : C }.

  Import Vectors.Vector.VectorNotations.

  Fixpoint i2list2 {n}
           (l : Vector.t A n)
           (il1 : ilist (B := B) l)
           (il2 : ilist (B := B') l) : Type :=
    match l return ilist (B := B) l
                   -> ilist (B := B') l
                   -> Type with
    | Vector.nil =>
      fun il1 il2 => unit
    | Vector.cons a n' l =>
      fun il1 il2 =>
        @prim_prod (C (prim_fst il1) (prim_fst il2))
                   (i2list2 l (prim_snd il1) (prim_snd il2))
    end il1 il2.

  Definition i2cons2
             {a : A}
             {n}
             {l : Vector.t A n}
             (b1 : B a)
             (il1 : ilist (B := B) l)
             (b2 : B' a)
             (il2 : ilist (B := B') l)
             (c : C b1 b2)
             (i2l' : i2list2 l il1 il2)
  : i2list2 (a :: l) (icons b1 il1) (icons b2 il2)
    := {| prim_fst := c; prim_snd := i2l' |}.

  Definition inil : i2list2 [] inil inil := tt.

  (* Get the car of an i2list2. *)

  Definition i2list2_hd {n} {As : Vector.t A n}
             {il1 : ilist (B := B) As}
             {il2 : ilist (B := B') As}
             (i2l : i2list2 As il1 il2) :
    match As return
          forall
            (il1 : ilist (B := B) As)
            (il2 : ilist (B := B') As),
            i2list2 As il1 il2 -> Type with
    | Vector.cons a _ As' =>
      fun Bs Bs' i2l => C (ilist_hd Bs) (ilist_hd Bs')
    | Vector.nil => fun _ _ _ => unit
    end il1 il2 i2l :=
    match As return
          forall il1 il2 i2l,
            match As return
                  forall
                    (il1 : ilist (B := B) As)
                    (il2 : ilist (B := B') As),
                    i2list2 As il1 il2 -> Type with
            | Vector.cons a _ As' =>
              fun Bs Bs' i2l => C (ilist_hd Bs) (ilist_hd Bs')
          | Vector.nil => fun _ _ _ => unit
            end il1 il2 i2l
    with
    | Vector.cons a _ As' =>
      fun il1 il2 i2l => prim_fst i2l
    | Vector.nil => fun _ _ _ => tt
    end il1 il2 i2l.

  (* Get the cdr of an i2list2. *)
  Definition i2list2_tl {n}
             {As : Vector.t A n}
             {il1 : ilist (B := B) As}
             {il2 : ilist (B := B') As}
             (i2l : i2list2 As il1 il2) :
    match As return
          forall
            (il1 : ilist (B := B) As)
            (il2 : ilist (B := B') As),
            i2list2 As il1 il2 -> Type with
    | Vector.cons a _ As' =>
      fun Bs Bs' i2l => i2list2 _ (ilist_tl Bs) (ilist_tl Bs')
    | Vector.nil => fun _ _ _ => unit
    end il1 il2 i2l :=
    match As return
          forall il1 il2 i2l,
            match As return
                  forall
                    (il1 : ilist (B := B) As)
                    (il2 : ilist (B := B') As),
                    i2list2 As il1 il2 -> Type with
            | Vector.cons a _ As' =>
              fun Bs Bs' i2l => i2list2 _ (ilist_tl Bs) (ilist_tl Bs')
          | Vector.nil => fun _ _ _ => unit
            end il1 il2 i2l
    with
    | Vector.cons a _ As' =>
      fun il1 il2 i2l => prim_snd i2l
    | Vector.nil => fun _ _ _ => tt
    end il1 il2 i2l.

  Fixpoint i2th2
             {m : nat}
             {As : Vector.t A m}
             (il1 : ilist (B := B) As)
             (il2 : ilist (B := B') As)
             (i2l : i2list2 As il1 il2)
             (n : Fin.t m)
  : C (ith il1 n) (ith il2 n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m)
                 (il1 : ilist (B := B) As)
                 (il2 : ilist (B := B') As),
            i2list2 _ il1 il2
            -> C (ith il1 n) (ith il2 n) with
      | Fin.F1 k =>
        fun As =>
          Vector.caseS (fun n As =>
                          forall (il1 : ilist (B := B) As)
                                 (il2 : ilist (B := B') As),
                            i2list2 As il1 il2
                            -> C (ith il1 (@Fin.F1 n))
                              (ith il2 (@Fin.F1 n)))
                       (fun h n t il1 il2 i2l => i2list2_hd i2l) As
      | Fin.FS k n' =>
        fun As =>
          Vector_caseS' Fin.t
                        (fun n As n' =>
                           forall (il1 : ilist (B := B) As)
                                  (il2 : ilist (B := B') As),
                             i2list2 As il1 il2
                             -> C (ith il1 (@Fin.FS n n'))
                               (ith il2 (@Fin.FS n n')))
                        (fun h n t m il1 il2 i2l =>
                           i2th2 (ilist_tl il1)
                                 (ilist_tl il2)
                                 (i2list2_tl i2l) m)
                        As n'
    end As il1 il2 i2l.

  (*
  (* Membership in a doubly-indexed list. *)
  Inductive i2list2_In
  : forall {a : A} {b : B a} {b' : B' a}
           (c : C b b') (As : list A)
           (il : ilist B As)
           (il' : ilist B' As)
           (i2l : i2list2 il il'), Prop :=
  | In2_hd : forall a' As
                    (Bs : ilist B (a' :: As))
                    (Bs' : ilist B' (a' :: As))
                    (i2l : i2list2 (ilist_tl Bs) (ilist_tl Bs')) c,
               i2list2_In c (i2cons2 Bs Bs' c i2l)
  | In2_tl : forall a a' As
                    (Bs : ilist B (a' :: As))
                    (Bs' : ilist B' (a' :: As))
                    (b : B a) (b' : B' a) c'
                    (i2l : i2list2 (ilist_tl Bs) (ilist_tl Bs'))
                    (c : C b b'),
               i2list2_In c i2l ->
               i2list2_In c (i2cons2 Bs Bs' c' i2l).

  (* Looking up the ith value, returning None for indices not in the list *)
  (* A doubly-dependent option. *)

  Fixpoint i2th_error2'
          (As : list A)
          (Bs : ilist B As)
          (Bs' : ilist B' As)
          (i2l : i2list2 Bs Bs')
          (n : nat)
          {struct n}
  : Dep_Option_elim_T2 C (ith_error Bs n) (ith_error Bs' n) :=
    match n as n' return
          forall (Bs : ilist B As)
                 (Bs' : ilist B' As),
            i2list2 Bs Bs'
            -> Dep_Option_elim_T2 C (ith_error Bs n') (ith_error Bs' n')
    with
      | 0 =>
        fun Bs Bs' i2l =>
          match i2l as i2l' in i2list2 Bss Bss' return
                Dep_Option_elim_T2 C (ith_error Bss 0) (ith_error Bss' 0) with
            | i2nil2 _ _ => tt
            | i2cons2 a As' Bss Bss' c i2l' => c
          end
      | S n => fun Bs Bs' i2l =>
                 match i2l as i2l' in i2list2 Bss Bss' return
                       Dep_Option_elim_T2 C (ith_error Bss (S n))
                                          (ith_error Bss' (S n)) with
                   | i2nil2 _ _ => tt
                   | i2cons2 a As' Bss Bss' c i2l' => i2th_error2' i2l' n
                 end
    end Bs Bs' i2l.

  (* Looking up the ith value, returning a default value
     for indices not in the list.
  Fixpoint i2th_default2
          (default_A : A)
          (default_B : B default_A)
          (default_C : C default_B)
          (As : list A)
          (Bs : ilist B As)
          (i2l : i2list2 Bs)
          (n : nat)
          {struct As}
  : C (ith2_default default_A default_B Bs n) :=
    match As as As', n as n' return
          forall (Bs' : ilist B As'),
            i2list2 Bs'
            -> C (ith2_default default_A default_B Bs' n') with
      | a :: As', 0    => @i2list2_hd (a :: As')
      | a :: As', S n' => fun il i2l => i2th_default2 default_C (i2list2_tl i2l) n'
      | nil      , 0    => fun il i2l => default_C
      | nil      , S n' => fun il i2l => default_C
    end Bs i2l.

  Lemma i2list2_invert (As : list A) (Bs : ilist B As) (Cs : i2list2 Bs):
    match Bs as Bs' return i2list2 Bs' -> Prop with
      | icons2 a As b Bs' => fun Cs =>
                           exists (c : C b) (Cs' : i2list2 Bs'),
                             Cs = i2cons2 (icons2 a b Bs') c Cs'
      | inil2 => fun Cs => Cs = i2nil2 (inil2 _)
    end Cs.
  Proof.
    destruct Cs.
    - destruct (ilist_invert Bs) as [b [Bs' Bs'_eq]]; subst.
      eexists; eauto.
    - pose (ilist_invert Bs) as Bs_eq; simpl in Bs_eq; subst; eauto.
  Qed.

  Lemma i2th_default2_In :
    forall (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 Bs)
           (default_A : A)
           (default_B : B default_A)
           (default_C : C default_B),
      n < List.length As ->
      i2list2_In (i2th_default2 default_C Cs n) Cs.
  Proof.
    ith2_induction n As; simpl;
    destruct (i2list2_invert Cs) as [c [Cs' Cs_eq]]; subst; simpl;
    [apply (In2_hd (icons2 a b il) Cs' c) |  constructor 2];
    eauto with arith.
  Qed.

  Lemma i2th_default2_indep :
    forall (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 Bs)
           (default_A : A)
           (default_B : B default_A)
           (default_C default_C' : C default_B),
      n < List.length As ->
      i2th_default2 default_C Cs n = i2th_default2 default_C' Cs n.
  Proof.
    ith_induction n As; simpl; eauto with arith.
  Qed. *)
 *)
End i2list2.
(*
Section i2list2_replace.

  (* Replacing an element of an indexed list. *)
  Variable A : Type. (* The indexing type. *)
  Variable B : A -> Type. (* The two types of indexed elements. *)
  Variable C : forall a, B a -> Type. (* The type of doubly-indexed elements. *)

  Program Fixpoint replace_2Index2
           (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 C Bs)
           (new_c : Dep_Option_elim_P C (ith2_error Bs n))
           {struct Bs} : i2list2 C Bs :=
    match n return
            i2list2 C Bs
            -> Dep_Option_elim_P C (ith2_error Bs n)
            -> i2list2 C Bs with
      | 0 => match Bs return
                     i2list2 C Bs
                     -> Dep_Option_elim_P C (ith2_error Bs 0)
                     -> i2list2 C Bs with
                 | inil2 =>
                   fun il _ => i2nil2 _ _
                 | icons2 a b As' Bs' =>
                   fun Cs' new_c =>
                     i2cons2 _ new_c (i2list2_tl Cs')
               end
      | S n => match Bs return
                     i2list2 C Bs
                     -> Dep_Option_elim_P C (ith2_error Bs (S n))
                     -> i2list2 C Bs with
                 | inil2 => fun il _ => i2nil2 _ _
                 | icons2 a As' b Bs' =>
                   fun Cs' new_c =>
                     i2cons2 _ (i2list2_hd Cs')
                            (@replace_2Index2 n As' Bs'
                                             (i2list2_tl Cs') new_c)
               end
    end Cs new_c.

  Lemma i2th_replace2_Index_neq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (n' : nat)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n')),
      n <> n'
      -> i2th_error2 (replace_2Index2 n' Cs new_c) n =
         i2th_error2 Cs n.
  Proof.
    induction n; simpl; destruct Bs; intros; icons2_invert;
    simpl in *; auto;
    destruct n'; simpl; try congruence.
    eapply IHn; congruence.
  Qed.

  Lemma i2th_replace2_Index_eq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n)),
      i2th_error2 (replace_2Index2 n Cs new_c) n = new_c.
  Proof.
    induction n; destruct Bs; simpl; auto; intros;
    destruct new_c; eauto.
  Qed.

  Program Fixpoint replace_2Index2'
           (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i2list2 C Bs)
           (new_c : Dep_Option_elim_P C (ith2_error Bs n))
           {struct Cs} : i2list2 C Bs :=
    match n return
          Dep_Option_elim_P C (ith2_error Bs n)
            -> i2list2 C Bs with
      | 0 => match Cs in i2list2 _ Bs return
                   Dep_Option_elim_P C (ith2_error Bs 0)
                   -> i2list2 C Bs with
                 | i2nil2 Bs =>
                   fun _ => i2nil2 _ Bs
                 | i2cons2 a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons2 Bs' new_c i2l'
               end
      | S n => match Cs in i2list2 _ Bs return
                     Dep_Option_elim_P C (ith2_error Bs (S n))
                     -> i2list2 C Bs with
                 | i2nil2 Bs => fun _ => i2nil2 _ Bs
                 | i2cons2 a As' Bs' c i2l' =>
                   fun new_c =>
                     i2cons2 Bs' c (@replace_2Index2' n As' (ilist_tl Bs') i2l' new_c)
               end
    end new_c.

  Lemma i2th_replace_2Index2'_neq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (n' : nat)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n')),
      n <> n'
      -> i2th_error2' (replace_2Index2' n' Cs new_c) n =
         i2th_error2' Cs n.
  Proof.
    induction n; simpl; destruct Cs; intros; icons2_invert;
    simpl in *; auto;
    destruct n'; simpl; try congruence.
    unfold replace_2Index2.
    eapply IHn; congruence.
  Qed.

  Lemma i2th_replace_2Index2'_eq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i2list2 C Bs)
      (new_c : Dep_Option_elim_P C (ith2_error Bs n)),
      i2th_error2' (replace_2Index2' n Cs new_c) n = new_c.
  Proof.
    induction n; destruct Cs; simpl; auto; intros;
    destruct new_c; eauto.
  Qed.

End i2list2_replace. *)


(** This file provides the user with the tactics needed to quote differential
    equations as [diff_equa] terms and use [Dequa_facts]' main theorem to solve
    them.

    In order to solve an equation [E(x)]:

    1. we represent it as couple [(env, e)] where:
    - [env] is a [list (sigT infinite_cv_radius)] such that every sequence [an]
    appears only once in [env];
    - [e] is a [diff_equa] term such that [interp_in_R e env x] is isomorphic to
    [E(x)] (the only difference being the proofs used to construct [sum]s and
    [nth_derive]s).

    2. we use [env] in order to normalise the goal using proof-irrelevance
    theorems (e.g. the fact that [sum an r1] is extensionaly equal to [sum an r2]
    so not distinguishing [sum an r1 x] from [sum an r2 x] was harmless).
*)

Require Import List.
Require Import Rsequence_def Rpser_def Rpser_def_simpl Rpser_sums Rpser_derivative Rpser_usual.
Require Import Rfunction_classes.
Require Import Nth_derivative_def Nth_derivative_facts.
Require Import Dequa_def Dequa_facts.

(** * Quoting differential equations *)

(** [isconst s x] yields a boolean value telling you whether [s] is an
    expression that does not depends on [x] or that does.
    Optimisation: our variable [x] will always appear as the last
    argument of the application so we chose a right to left depth-first
    search algorithm. **)

Ltac isconst := fun s x => match s with
  | x     => false
  | ?f ?e =>
    match isconst e x with
      | true  => isconst f x
      | false => false
    end
  | ?y    => true
end.

(** [add_var an rho l] adds the sequence [an] and the proof that its
    radius of convergence is infinite [rho] to the environment and
    returns an integer representing it.
    If [an] is already in the environment (no matter what the proof
    looks like), we do not reinsert it. This allows us to create the
    most general differential equation. **)

Ltac add_var an rho l :=
  let rec aux an rho l n :=
  match l with
    | List.nil                    => constr:(pair n (List.cons (existT _ an rho) List.nil))
    | List.cons (existT _ an _) _ => constr:(pair n l)
    | List.cons ?a ?tl =>
      match aux an rho tl (S n) with
        | (?m , ?tl') => constr:(pair m (List.cons a tl'))
      end
  end in aux an rho l O.

(** [quote_side_equa env s x] quotes the side equation [s] whose variable
    is [x] according to the current environment [env].
    If [s] is a constant with respect to [x] then we do not look at its structure
    and represent it as a [cst s]. If [s] is a kth derivative then we try to find
    [k] and we use the appropriate representation [y p k] where [p] is the
    representation of [s] in the environment.
    Otherwise we deconstruct [s] until we reach either a constant or a function. **)

Ltac quote_side_equa := fun env s x => match isconst s x with
  | true  => constr: (pair env (cst s))
  | false =>
    match constr:(s) with
(* Common constructors for arithmetical operations *)
      | Ropp ?s1       =>
        match quote_side_equa env s1 x with
         | (?env1, ?p) => constr: (pair env1 (opp p))
        end
      | Rmult ?s1 ?s2  =>
        match isconst s1 x with
          | true  =>
            match quote_side_equa env s2 x with
              | (?env1, ?p) => constr: (pair env1 (scal s1 p))
            end
          | false =>
            match isconst s2 x with
              | true  =>
                match quote_side_equa env s1 x with
                  | (?env1, ?p) => constr: (pair env1 (scal s2 p))
                end
              | false =>
                match quote_side_equa env s1 x with
                  | (?env1, ?p) =>
                    match quote_side_equa env1 s2 x with
                      | (?env2, ?q) => constr: (pair env2 (mult p q))
            	    end
                end
	    end
        end
      | Rminus ?s1 ?s2 =>
        match quote_side_equa env s1 x with
          | (?env1, ?p) =>
            match quote_side_equa env1 s2 x with
              | (?env2, ?q) => constr: (pair env2 (min p q))
            end
        end
      | Rplus ?s1 ?s2  =>
        match quote_side_equa env s1 x with
          | (?env1, ?p) =>
            match quote_side_equa env1 s2 x with
              | (?env2, ?q) => constr: (pair env2 (plus p q))
            end
        end
(* Function symbols *)
      | derive (sum ?an ?rho) ?c x =>
        match add_var an rho env with
          | (?p, ?env') => constr: (pair env' (y p 1 1))
        end
      | nth_derive (sum ?an ?rho) ?c x =>
        match add_var an rho env with
          | (?p, ?env') =>
            match type of c with
              | D ?k (sum an rho) => constr: (pair env' (y p k 1))
            end
        end
      | sum ?an ?rho x =>
        match add_var an rho env with
          | (?p, ?env') => constr: (pair env' (y p 0 1))
        end
      | x =>
        match add_var identity_seq identity_infinite_cv_radius env with
          | (?p, ?env') => constr: (pair env' (y p 0 1))
        end
      | derive (sum ?an ?rho) ?c (?a * x) =>
        match add_var an rho env with
          | (?p, ?env') => constr: (pair env' (y p 1 a))
        end
      | nth_derive (sum ?an ?rho) ?c (?a * x) =>
        match add_var an rho env with
          | (?p, ?env') =>
            match type of c with
              | D ?k (sum an rho) => constr: (pair env' (y p k a))
            end
        end
      | sum ?an ?rho (?a * x) =>
        match add_var an rho env with
          | (?p, ?env') => constr: (pair env' (y p 0 a))
        end
(** If everything fails, we output a 404 constant.
    Just for testing; should be removed (TODO) **)
      | _ => constr: (pair env (cst 404))
    end
end.

(** Adhoc lemmas to be moved? **)

Require Import Rfunction_def Rextensionality.

Lemma nth_derive_sum_PI_O : forall an (r1 r2 : infinite_cv_radius an),
  nth_derive (sum an r1) (D_infty_Rpser an r1 O) == sum an r2.
Proof.
intros an r1 r2 ; apply sum_ext ; reflexivity.
Qed.

Lemma nth_derive_sum_PI_O' : forall an (r1 r2 : infinite_cv_radius an),
 (fun x => nth_derive (sum an r1) (D_infty_Rpser an r1 O) (1 * x)) == sum an r2.
Proof.
intros an r1 r2 x ; rewrite Rmult_1_l ; apply nth_derive_sum_PI_O.
Qed.

Lemma nth_derive_sum_PI_1 : forall an (r1 r2 : infinite_cv_radius an) (pr : derivable (sum an r2)),
  nth_derive (sum an r1) (D_infty_Rpser an r1 1%nat) == derive (sum an r2) pr.
Proof.
intros an r1 r2 pr ; apply derive_ext, sum_ext ; reflexivity.
Qed.

Lemma nth_derive_sum_PI_1' : forall an (r1 r2 : infinite_cv_radius an) (pr : derivable (sum an r2)),
  (fun x => nth_derive (sum an r1) (D_infty_Rpser an r1 1%nat) (1 * x)) == derive (sum an r2) pr.
Proof.
intros an r1 r2 pr x ; rewrite Rmult_1_l ; apply nth_derive_sum_PI_1.
Qed.

Lemma nth_derive_sum_PI: forall (n : nat) an (r1 r2 : infinite_cv_radius an) (pr : D n (sum an r2)),
  nth_derive (sum an r1) (D_infty_Rpser an r1 n) == nth_derive (sum an r2) pr.
Proof.
intros n an r1 r2 pr ; apply nth_derive_ext, sum_ext ; reflexivity.
Qed.

Lemma nth_derive_sum_PI': forall (n : nat) an (r1 r2 : infinite_cv_radius an) (pr : D n (sum an r2)),
  (fun x => nth_derive (sum an r1) (D_infty_Rpser an r1 n) (1 * x)) == nth_derive (sum an r2) pr.
Proof.
intros n an r1 r2 pr x ; rewrite Rmult_1_l ; apply nth_derive_sum_PI.
Qed.

(** Normalising the goal **)

Ltac normalize_rec := fun p s x =>
match p with | (existT _ ?an ?rho) =>
match isconst s x with | false =>
  match s with
    | Ropp ?s1 => progress (normalize_rec p s1 x)
    | Rplus ?s1 ?s2 => progress (normalize_rec p s1 x)
    | Rplus ?s1 ?s2 => progress (normalize_rec p s2 x)
    | Rminus ?s1 ?s2 => progress (normalize_rec p s1 x)
    | Rminus ?s1 ?s2 => progress (normalize_rec p s2 x)
    | Rmult ?s1 ?s2 =>
      match isconst s2 x with
        | true => replace (Rmult s1 s2)%R with (Rmult s2 s1)%R by (apply Rmult_comm)
        | false => progress (normalize_rec p s1 x) ; progress (normalize_rec p s2 x)
        | false => progress (normalize_rec p s1 x)
        | false => progress (normalize_rec p s2 x)
      end
    | sum an ?rho2 x => replace (sum an rho2 x)%R with
                        (nth_derive (sum an rho) (D_infty_Rpser an rho O) (1 * x))%R
                        by (apply (nth_derive_sum_PI_O' an rho rho2 x))
    | derive (sum an ?rho2) ?pr x => replace (derive (sum an rho2) pr x)%R with
                        (nth_derive (sum an rho) (D_infty_Rpser an rho 1%nat) (1 * x))%R
                        by (apply (nth_derive_sum_PI_1' an rho rho2 pr x))
    | sum an ?rho2 (?a * x) => replace (sum an rho2 (a * x))%R with
                        (nth_derive (sum an rho) (D_infty_Rpser an rho O) (a * x))%R
                        by (apply (nth_derive_sum_PI_O an rho rho2 (a * x)))
    | derive (sum an ?rho2) ?pr (?a * x) => replace (derive (sum an rho2) pr (a * x))%R with
                        (nth_derive (sum an rho) (D_infty_Rpser an rho 1%nat) (a * x))%R
                        by (apply (nth_derive_sum_PI_1 an rho rho2 pr (a * x)))
(** This case is special: we want to do something iff the nth_derive has not
    the right shape. **)
    | nth_derive (sum an rho) (D_infty_Rpser an rho ?n) x =>
       replace (nth_derive (sum an rho) (D_infty_Rpser an rho n) x)%R with
       (nth_derive (sum an rho) (D_infty_Rpser an rho n) (1 * x))%R
       by (rewrite Rmult_1_l ; reflexivity)
    | nth_derive (sum an ?rho2) ?pr x =>
      match type of pr with | C ?n (sum an rho2) =>
        replace (nth_derive (sum an rho2) pr x)%R with
        (nth_derive (sum an rho) (D_infty_Rpser an rho n) (1 * x))%R
        by (apply nth_derive_sum_PI')
      end
    | nth_derive (sum an rho) (D_infty_Rpser an rho ?n) (?a * x) => idtac
    | nth_derive (sum an ?rho2) ?pr (?a * x) =>
      match type of pr with | C ?n (sum an rho2) =>
        replace (nth_derive (sum an rho2) pr (a * x))%R with
        (nth_derive (sum an rho) (D_infty_Rpser an rho n) (a * x))%R
        by (apply nth_derive_sum_PI)
      end
  end
end
end.

Ltac normalize := fun env s x =>
match env with
  | List.nil => idtac
  | List.cons ?p ?env2 => repeat (normalize_rec p s x) ; normalize env2 s x
end.

Ltac quote_diff_equa := fun x =>
match goal with
  | |- ?s1 = ?s2 =>
   match quote_side_equa (@List.nil (sigT infinite_cv_radius)) s1 x with
    | (?env1, ?p) =>
     match quote_side_equa env1 s2 x with
       | (?env2, ?q) => constr: (pair env2 (p :=: q))
     end
   end
end.

(** Solving an equation **)

Ltac solve_diff_equa_on := fun x =>
let H := fresh "H" in
match quote_diff_equa x with
  | (?env, ?p) =>
    match goal with
      | |- ?s1 = ?s2 => normalize env s1 x ; normalize env s2 x ;
                        cut ([| p |]N (map (@projT1 _ infinite_cv_radius) env)) ;
                        [intro H ; apply (interp_equa_in_N_R _ _ H x) ; clear H | simpl ;
                        repeat rewrite An_expand_1 ; repeat rewrite An_nth_deriv_0 ;
                        repeat rewrite An_nth_deriv_1 ]
    end
end.

Ltac solve_diff_equa :=
let x := fresh "x" in intro x ; solve_diff_equa_on x.

(* TODO *)

(** * Test materials *)
(** TODO: remove everything in this section as soon as the library is
   working *)

Goal forall an (ra rb : infinite_cv_radius an) x, sum an ra x = sum an rb x.
intros an ra rb ; solve_diff_equa ; reflexivity.
Qed.

Goal forall an bn (ra: infinite_cv_radius an) (rb rc: infinite_cv_radius bn)
 (rab: infinite_cv_radius (an + bn + bn)), forall (u x : R),
  (sum (an + bn + bn)%Rseq rab x = sum bn rb x + sum an ra x + sum bn rc x)%R.
intros an bn ra rb rc rab x.
 solve_diff_equa ; intro n ; unfold Rseq_plus ; ring.
Qed.


Require Import Cryptol.Coqlib.
Require Import String.
Require Import Cryptol.Lib.
Definition ident : Type := Z * string.

Definition ident_eq :
  forall (x y : ident),
    { fst x = fst y } + { fst x <> fst y }.
Proof.
  decide equality;
  eapply Pos.eq_dec.
Defined.

Definition extend { vtype : Type } (E : ident -> option vtype) (id : ident) (v : vtype) :=
  fun x => if ident_eq x id then Some v else E x.

Inductive Expr :=
| EVar (id : ident)
| EConst (z : Z)
| EList (l : list Expr)
.

Definition Expr_ind_full
           (P : Expr -> Prop)
           (Pl : list Expr -> Prop)
           (PVar : forall id, P (EVar id))
           (PConst : forall z, P (EConst z))
           (PList : forall l, Pl l -> P (EList l))
           (Hnil : Pl nil)
           (Hcons : forall f r, P f -> Pl r -> Pl (f :: r))
           (e : Expr)
  : P e :=
  let fix go e :=
  let fix go_list l :=
      match l as _l return Pl _l with
      | nil => Hnil
      | f :: r => Hcons f r (go f) (go_list r)
      end in
  match e with
  | EVar id => PVar id
  | EConst z => PConst z
  | EList l => PList l (go_list l)
  end in
  go e.

Definition Expr_ind_useful
           (P : Expr -> Prop)
           (PVar : forall id, P (EVar id))
           (PConst : forall z, P (EConst z))
           (PList : forall l, Forall P l -> P (EList l))
           (e : Expr)
  : P e.
  eapply Expr_ind_full. eauto. eauto.
  eapply PList. econstructor.
  intros. econstructor; eauto.
Defined.

Inductive val :=
| num (z : Z)
| listval (l : list val)
.

Definition genv : Type := ident -> option Expr.
Definition gempty : genv := fun _ => None.
Definition env : Type := ident -> option val.

Inductive eval_expr : genv -> env -> Expr -> val -> Prop :=
| eval_global_var :
    forall ge id E v e,
      ge id = Some e ->
      E id = None ->
      eval_expr ge E e v -> (* This line is the killer *)
      eval_expr ge E (EVar id) v
| eval_list :
    forall ge l vs E,
      Forall2 (eval_expr ge E) l vs ->
      eval_expr ge E (EList l) (listval vs)
| eval_local_var :
    forall ge id E v,
      E id = Some v ->
      eval_expr ge E (EVar id) v
| eval_const :
    forall ge z E,
      eval_expr ge E (EConst z) (num z)
.

Definition eval_expr_ind_total
  (P : genv -> env -> Expr -> val -> Prop)
  (Pl : genv -> env -> list Expr -> list val -> Prop)
  (Hglobal_var : forall (ge : ident -> option Expr) (id : ident)
                        (E : ident -> option val) (v : val) (e : Expr),
      ge id = Some e ->
      E id = None -> eval_expr ge E e v -> P ge E e v -> P ge E (EVar id) v)
  (Hlist : forall (ge : genv) (l : list Expr) (vs : list val) (E : env),
      Forall2 (eval_expr ge E) l vs ->
      Pl ge E l vs ->
      P ge E (EList l) (listval vs))
  (Hlocal_var : forall (ge : genv) (id : ident) (E : ident -> option val) (v : val),
      E id = Some v -> P ge E (EVar id) v)
  (Hconst : forall (ge : genv) (z : Z) (E : env), P ge E (EConst z) (num z))
  (HPlnil : forall ge E, Pl ge E nil nil)
  (HPlcons : forall ge E e v es vs,
      P ge E e v ->
      Pl ge E es vs ->
      Pl ge E (e :: es) (v :: vs))
  (ge : genv)
  (E : env)
  (expr : Expr)
  (v : val)
  (eval : eval_expr ge E expr v) : P ge E expr v :=
  let fix go ge E exp v eval : P ge E exp v :=
      let fix go_list ge E es vs f2eval : Pl ge E es vs :=
          match f2eval in (Forall2 _ es0 vs0) return (Pl ge E es0 vs0) with
          | Forall2_nil => HPlnil ge E
          | Forall2_cons e' v' es' vs' eval_fst forall_eval_rest =>
            HPlcons ge E e' v' es' vs' (go ge E e' v' eval_fst) (go_list ge E es' vs' forall_eval_rest)
          end
          in
      match eval in (eval_expr ge0 E0 exp0 v0) return (P ge0 E0 exp0 v0) with
      | eval_global_var ge id E v P2 P3 P4 P5 =>
        Hglobal_var ge id E v P2 P3 P4 P5 (go ge E P2 v P5)
      | eval_list ge l vs E P3 =>
        Hlist ge l vs E P3 (go_list ge E l vs P3)
      | eval_local_var ge id E v P2 => Hlocal_var ge id E v P2
      | eval_const ge z E => Hconst ge z E
      end in
          go ge E expr v eval.

Definition eval_expr_ind_useful
  (P : genv -> env -> Expr -> val -> Prop)
  (Hglobal_var : forall (ge : ident -> option Expr) (id : ident)
                        (E : ident -> option val) (v : val) (e : Expr),
      ge id = Some e ->
      E id = None -> eval_expr ge E e v -> P ge E e v -> P ge E (EVar id) v)
  (Hlist : forall (ge : genv) (l : list Expr) (vs : list val) (E : env),
      Forall2 (eval_expr ge E) l vs ->
      Forall2 (P ge E) l vs ->
      P ge E (EList l) (listval vs))
  (Hlocal_var : forall (ge : genv) (id : ident) (E : ident -> option val) (v : val),
      E id = Some v -> P ge E (EVar id) v)
  (Hconst : forall (ge : genv) (z : Z) (E : env), P ge E (EConst z) (num z))
  (ge : genv)
  (E : env)
  (expr : Expr)
  (v : val)
  (eval : eval_expr ge E expr v) : P ge E expr v .
  eapply eval_expr_ind_total; intros; try solve [eauto].
  eapply Hlist. eassumption.
  eapply H0.
  simpl. econstructor.
  simpl in *. econstructor; eauto.
Defined.

Lemma eval_expr_swap_ge :
  forall ge E expr v,
    eval_expr ge E expr v ->
    forall ge',
      (forall id exp,
          ge id = Some exp ->
          ge' id = Some exp) ->
      eval_expr ge' E expr v.
Proof.
  intros.
  induction H using eval_expr_ind_useful; intros.
  - apply eval_global_var with e; auto.
  - econstructor.

    induction H1; eauto.
    inversion H. subst.
    econstructor; eauto.

  - apply eval_local_var. auto.
  - constructor; auto.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Cos_rel.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
Open Local Scope R_scope.

Definition A1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) N.

Definition B1 (x:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    N.

Definition C1 (x y:R) (N:nat) : R :=
  sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) N.

Definition Reste1 (x y:R) (N:nat) : R :=
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) * ((-1) ^ (N - l) / INR (fact (2 * (N - l)))) *
            y ^ (2 * (N - l))) (pred (N - k))) (pred N).

Definition Reste2 (x y:R) (N:nat) : R :=
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (N - l) / INR (fact (2 * (N - l) + 1))) *
            y ^ (2 * (N - l) + 1)) (pred (N - k))) (
    pred N).

Definition Reste (x y:R) (N:nat) : R := Reste2 x y N - Reste1 x y (S N).

(* Here is the main result that will be used to prove that (cos (x+y))=(cos x)(cos y)-(sin x)(sin y) *)
Theorem cos_plus_form :
 forall (x y:R) (n:nat),
   (0 < n)%nat ->
   A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n).
intros.
unfold A1, B1 in |- *.
rewrite
 (cauchy_finite (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k))
    (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * y ^ (2 * k)) (
    S n)).
rewrite
 (cauchy_finite
    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * y ^ (2 * k + 1)) n H)
 .
unfold Reste in |- *.
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k))) *
            x ^ (2 * S (l + k)) *
            ((-1) ^ (S n - l) / INR (fact (2 * (S n - l))) *
             y ^ (2 * (S n - l)))) (pred (S n - k))) (
    pred (S n))) with (Reste1 x y (S n)).
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun l:nat =>
            (-1) ^ S (l + k) / INR (fact (2 * S (l + k) + 1)) *
            x ^ (2 * S (l + k) + 1) *
            ((-1) ^ (n - l) / INR (fact (2 * (n - l) + 1)) *
             y ^ (2 * (n - l) + 1))) (pred (n - k))) (
    pred n)) with (Reste2 x y n).
replace
 (sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p)) * x ^ (2 * p) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p))) * y ^ (2 * (k - p))))
         k) (S n)) with
 (sum_f_R0
    (fun k:nat =>
       (-1) ^ k / INR (fact (2 * k)) *
       sum_f_R0
         (fun l:nat => C (2 * k) (2 * l) * x ^ (2 * l) * y ^ (2 * (k - l))) k)
    (S n)).
pose
 (sin_nnn :=
  fun n:nat =>
    match n with
    | O => 0
    | S p =>
        (-1) ^ S p / INR (fact (2 * S p)) *
        sum_f_R0
          (fun l:nat =>
             C (2 * S p) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (p - l))) p
    end).
ring_simplify.
unfold Rminus.
replace
(* (-   old ring compat *)
 (-
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n) with (sum_f_R0 sin_nnn (S n)).
rewrite <- sum_plus.
unfold C1 in |- *.
apply sum_eq; intros.
induction  i as [| i Hreci].
simpl in |- *.
unfold C in |- *; simpl in |- *.
field; discrR.
unfold sin_nnn in |- *.
rewrite <- Rmult_plus_distr_l.
apply Rmult_eq_compat_l.
rewrite binomial.
pose (Wn := fun i0:nat => C (2 * S i) i0 * x ^ i0 * y ^ (2 * S i - i0)).
replace
 (sum_f_R0
    (fun l:nat => C (2 * S i) (2 * l) * x ^ (2 * l) * y ^ (2 * (S i - l)))
    (S i)) with (sum_f_R0 (fun l:nat => Wn (2 * l)%nat) (S i)).
replace
 (sum_f_R0
    (fun l:nat =>
       C (2 * S i) (S (2 * l)) * x ^ S (2 * l) * y ^ S (2 * (i - l))) i) with
 (sum_f_R0 (fun l:nat => Wn (S (2 * l))) i).
apply sum_decomposition.
apply sum_eq; intros.
unfold Wn in |- *.
apply Rmult_eq_compat_l.
replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))).
reflexivity.
omega.
apply sum_eq; intros.
unfold Wn in |- *.
apply Rmult_eq_compat_l.
replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat.
reflexivity.
omega.
replace
 (-
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n) with
 (-1 *
  sum_f_R0
    (fun k:nat =>
       sum_f_R0
         (fun p:nat =>
            (-1) ^ p / INR (fact (2 * p + 1)) * x ^ (2 * p + 1) *
            ((-1) ^ (k - p) / INR (fact (2 * (k - p) + 1)) *
             y ^ (2 * (k - p) + 1))) k) n);[idtac|ring].
rewrite scal_sum.
rewrite decomp_sum.
replace (sin_nnn 0%nat) with 0.
rewrite Rplus_0_l.
change (pred (S n)) with n.
   (* replace (pred (S n)) with n; [ idtac | reflexivity ]. *)
apply sum_eq; intros.
rewrite Rmult_comm.
unfold sin_nnn in |- *.
rewrite scal_sum.
rewrite scal_sum.
apply sum_eq; intros.
unfold Rdiv in |- *.
(*repeat rewrite Rmult_assoc.*)
(* rewrite (Rmult_comm (/ INR (fact (2 * S i)))). *)
repeat rewrite <- Rmult_assoc.
rewrite <- (Rmult_comm (/ INR (fact (2 * S i)))).
repeat rewrite <- Rmult_assoc.
replace (/ INR (fact (2 * S i)) * C (2 * S i) (S (2 * i0))) with
 (/ INR (fact (2 * i0 + 1)) * / INR (fact (2 * (i - i0) + 1))).
replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ idtac | ring ].
replace (S (2 * (i - i0))) with (2 * (i - i0) + 1)%nat; [ idtac | ring ].
replace ((-1) ^ S i) with (-1 * (-1) ^ i0 * (-1) ^ (i - i0)).
ring.
simpl in |- *.
pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
rewrite pow_add.
ring.
symmetry  in |- *; apply le_plus_minus; assumption.
unfold C in |- *.
unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l.
rewrite Rinv_mult_distr.
replace (S (2 * i0)) with (2 * i0 + 1)%nat;
 [ apply Rmult_eq_compat_l | ring ].
replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat.
reflexivity.
omega.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
reflexivity.
apply lt_O_Sn.
(* ring. *)
apply sum_eq; intros.
rewrite scal_sum.
apply sum_eq; intros.
unfold Rdiv in |- *.
repeat rewrite <- Rmult_assoc.
rewrite <- (Rmult_comm (/ INR (fact (2 * i)))).
repeat rewrite <- Rmult_assoc.
replace (/ INR (fact (2 * i)) * C (2 * i) (2 * i0)) with
 (/ INR (fact (2 * i0)) * / INR (fact (2 * (i - i0)))).
replace ((-1) ^ i) with ((-1) ^ i0 * (-1) ^ (i - i0)).
ring.
pattern i at 2 in |- *; replace i with (i0 + (i - i0))%nat.
rewrite pow_add.
ring.
symmetry  in |- *; apply le_plus_minus; assumption.
unfold C in |- *.
unfold Rdiv in |- *; repeat rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l.
rewrite Rinv_mult_distr.
replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat.
reflexivity.
omega.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
apply INR_fact_neq_0.
unfold Reste2 in |- *; apply sum_eq; intros.
apply sum_eq; intros.
unfold Rdiv in |- *; ring.
unfold Reste1 in |- *; apply sum_eq; intros.
apply sum_eq; intros.
unfold Rdiv in |- *; ring.
apply lt_O_Sn.
Qed.

Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i.
intros.
assert (H := pow_Rsqr x i).
unfold Rsqr in H; exact H.
Qed.

Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x).
intro.
assert (H := exist_cos (x * x)).
elim H; intros.
assert (p_i := p).
unfold cos_in in p.
unfold cos_n, infinite_sum in p.
unfold R_dist in p.
cut (cos x = x0).
intro.
rewrite H0.
unfold Un_cv in |- *; unfold R_dist in |- *; intros.
elim (p eps H1); intros.
exists x1; intros.
unfold A1 in |- *.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * x ^ (2 * k)) n) with
 (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * (x * x) ^ i) n).
apply H2; assumption.
apply sum_eq.
intros.
replace ((x * x) ^ i) with (x ^ (2 * i)).
reflexivity.
apply pow_sqr.
unfold cos in |- *.
case (exist_cos (Rsqr x)).
unfold Rsqr in |- *; intros.
unfold cos_in in p_i.
unfold cos_in in c.
apply uniqueness_sum with (fun i:nat => cos_n i * (x * x) ^ i); assumption.
Qed.

Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)).
intros.
assert (H := exist_cos ((x + y) * (x + y))).
elim H; intros.
assert (p_i := p).
unfold cos_in in p.
unfold cos_n, infinite_sum in p.
unfold R_dist in p.
cut (cos (x + y) = x0).
intro.
rewrite H0.
unfold Un_cv in |- *; unfold R_dist in |- *; intros.
elim (p eps H1); intros.
exists x1; intros.
unfold C1 in |- *.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k)) * (x + y) ^ (2 * k)) n)
 with
 (sum_f_R0
    (fun i:nat => (-1) ^ i / INR (fact (2 * i)) * ((x + y) * (x + y)) ^ i) n).
apply H2; assumption.
apply sum_eq.
intros.
replace (((x + y) * (x + y)) ^ i) with ((x + y) ^ (2 * i)).
reflexivity.
apply pow_sqr.
unfold cos in |- *.
case (exist_cos (Rsqr (x + y))).
unfold Rsqr in |- *; intros.
unfold cos_in in p_i.
unfold cos_in in c.
apply uniqueness_sum with (fun i:nat => cos_n i * ((x + y) * (x + y)) ^ i);
 assumption.
Qed.

Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x).
intro.
case (Req_dec x 0); intro.
rewrite H.
rewrite sin_0.
unfold B1 in |- *.
unfold Un_cv in |- *; unfold R_dist in |- *; intros; exists 0%nat; intros.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * 0 ^ (2 * k + 1))
    n) with 0.
unfold Rminus in |- *; rewrite Rplus_opp_r; rewrite Rabs_R0; assumption.
induction  n as [| n Hrecn].
simpl in |- *; ring.
rewrite tech5; rewrite <- Hrecn.
simpl in |- *; ring.
unfold ge in |- *; apply le_O_n.
assert (H0 := exist_sin (x * x)).
elim H0; intros.
assert (p_i := p).
unfold sin_in in p.
unfold sin_n, infinite_sum in p.
unfold R_dist in p.
cut (sin x = x * x0).
intro.
rewrite H1.
unfold Un_cv in |- *; unfold R_dist in |- *; intros.
cut (0 < eps / Rabs x);
 [ intro
 | unfold Rdiv in |- *; apply Rmult_lt_0_compat;
    [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ] ].
elim (p (eps / Rabs x) H3); intros.
exists x1; intros.
unfold B1 in |- *.
replace
 (sum_f_R0 (fun k:nat => (-1) ^ k / INR (fact (2 * k + 1)) * x ^ (2 * k + 1))
    n) with
 (x *
  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n).
replace
 (x *
  sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
  x * x0) with
 (x *
  (sum_f_R0 (fun i:nat => (-1) ^ i / INR (fact (2 * i + 1)) * (x * x) ^ i) n -
   x0)); [ idtac | ring ].
rewrite Rabs_mult.
apply Rmult_lt_reg_l with (/ Rabs x).
apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption.
rewrite <- Rmult_assoc.
rewrite <- Rinv_l_sym.
rewrite Rmult_1_l; rewrite <- (Rmult_comm eps); unfold Rdiv in H4; apply H4;
 assumption.
apply Rabs_no_R0; assumption.
rewrite scal_sum.
apply sum_eq.
intros.
rewrite pow_add.
rewrite pow_sqr.
simpl in |- *.
ring.
unfold sin in |- *.
case (exist_sin (Rsqr x)).
unfold Rsqr in |- *; intros.
unfold sin_in in p_i.
unfold sin_in in s.
assert
 (H1 := uniqueness_sum (fun i:nat => sin_n i * (x * x) ^ i) x0 x1 p_i s).
rewrite H1; reflexivity.
Qed.


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

Coq < Section Conjunctive_StratA.

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

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

Unnamed_thm < intros.
1 subgoal

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

Unnamed_thm < destruct H.
1 subgoal

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

Unnamed_thm < destruct H0.
1 subgoal

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

Unnamed_thm < apply H0.
No more subgoals.

Unnamed_thm < Qed.
intros.
destruct H.
destruct H0.
apply H0.

Unnamed_thm is defined

Coq <

*)

Section Combination_B.
Goal forall a b c:Prop, ((a -> b) /\ (c /\ b) /\ (c -> a)) -> c.
intros.
destruct H.
destruct H0.
apply H0.
Qed.


Set Implicit Arguments.

Require Import List Logic Basics FunctionalExtensionality ClassicalFacts Ensembles.
Require Import ListSet Bool Peano_dec.
Import ListNotations.

(* Blocage avec ListSet, utilisation d'un autre type de set
     - blocage sur step (comment faire le forall sur les couples states)
Section PropSet.
Variables A B C: Type.
Definition set (A: Type) := A -> Prop.
Definition singleton (x: A) := fun y => x = y.
Definition set_map (f: A -> B) (s: set A) : set B :=
  fun b => exists a, s a /\ f a = b.
Definition sets_union (s: set (set A)): set A :=
  fun a => exists sub_set, s sub_set /\ sub_set a.
Definition set_union (s1 s2 : set A) :=
  fun x => s1 x \/ s2 x.
Definition composition (r: set (A * B)) (s: set (B * C)): set (A * C) :=
  (fun elem =>
      let (a, c) := elem in
      exists b, r (a, b) /\ s (b, c)).
End PropSet.

Definition prepend_list_set (A: Type) (a: A) (s: set (list A)) : set (list A) :=
  fun r =>
    match r with
    | [] => False
    | b::rq => a = b /\ s rq
    end.*)

Section Nfa.

Variable A S: Type.
Variable Seq_dec: forall x y:S, {x = y} + {x <> y}.

(*Un automate est un triplet, avec :
  - un  état initial
  - une fonction de transition qui,
    à partir d'un état et une action, donne un ensemble d'états.
  - un ensemble d'états finaux
*)
Record nfa := mkNfa {
  start : S;
  next : A -> S -> set S;
  fin : set S
}.

Fixpoint accepts_from nfa s w :=
  match w with
  | [] => set_mem Seq_dec s (fin nfa)
  | h::q =>
      let aux :=
        fun b s =>
          b || accepts_from nfa s q
      in
      set_fold_left aux (next nfa h s) false
  end.

Definition accepts nfa w := accepts_from nfa (start nfa) w.

(*(*Inductive accepts_from (nfa: nfa) (s: S) : list A -> Prop :=
| accepts_nil : In _ (fin nfa) s -> accepts_from nfa s []
| accepts_cons : forall e h q, In _ (next nfa h s) e -> accepts_from nfa e q -> accepts_from nfa s (h::q).

Definition accepts (nfa: nfa) : list A -> Prop := accepts_from nfa (start nfa).

Fixpoint nfa_accepts (nfa: nfa) (w: list A) (s: S): Prop :=
  match w with
  | [] => fin nfa s
  | a::wq => exists y, (next nfa a s y) /\ nfa_accepts nfa wq y
  end.*)

(*Les couples (p, q)*)
Inductive step nfa a : Ensemble (S * S) :=
  | In_step : forall p q, In _ (next nfa a p) q -> step nfa a (p, q).
Hint Resolve step.

Inductive steps nfa : list A -> Ensemble (S * S) :=
  | In_steps_nil : forall s, steps nfa [] (s, s)
  | In_steps_cons : forall h q sa sb sc, step nfa h (sa, sb) -> steps nfa q (sb, sc) -> steps nfa (h::q) (sa, sc).

Definition accepts (nfa: nfa) (w: list A) :=
  exists k: S, In _ (fin nfa) k /\ In _ (steps nfa w) (start nfa, k).

(*Fixpoint delta (nfa: nfa) (w: list A) (s: S): set S :=
  match w with
  | nil => Singleton s
  | h::q => sets_union (set_map (delta nfa q) (next nfa h s))
  end.*)

(*Definition accepts (nfa: nfa) (w: list A): Prop :=
  nfa_accepts nfa w (start nfa).*)

(*Tout les couples(p, q) de states S qui ont une transition a
Definition step (nfa: nfa) (a: A): set (S * S) :=
  fun c =>
    let (p, q) := c in
    next nfa a p q.

(*Tout les couples(p, q) de states S*)
Fixpoint steps (nfa: nfa) (w: list A): set (S * S) :=
  match w with
  | nil =>
    (fun c =>
      let (p, q) := c in
      p = q)
  | h::wq =>
    composition (step nfa h) (steps nfa wq)
  end.

Variable v w: list A.

Lemma set_eqI: forall s r : set (S * S),
  s = r <-> forall x, s x <-> r x.

  split.
  intro.
Admitted.

Lemma assoc_composition :
  forall s r t : set (S * S), composition (composition s r) t = composition s (composition r t).

  intros.
  unfold composition.
Admitted.

Lemma steps_append : forall r, steps r (v ++ w) = composition (steps r v) (steps r w).
Proof.
  induction v.
  intro r.
  apply set_eqI.
  intro x.
  destruct x as (a, b).
  simpl.
  split.
  intro.
  exists a.
  tauto.
  intro.
  destruct H.
  destruct H.
  rewrite H.
  assumption.
  simpl ((a :: l) ++ w).
  intro r.
  simpl (steps r (a :: l)).
  simpl (steps r (a :: l ++ w)).
  rewrite assoc_composition.
  rewrite IHl.
  reflexivity.
Qed.

Lemma in_steps_append :
    forall p q r,
    steps r (v ++ w) (p, q) <-> composition (steps r v) (steps r w) (p, q).

  intros p q r.
  apply set_eqI.
  rewrite steps_append.
  reflexivity.
Qed.

Lemma delta_conv_steps : forall r p,
  delta r w p = (fun q => steps r w (p, q)).
Admitted.

End Nfa.

Section Test.

Axiom H : prop_extensionality.

Goal composition (singleton (1, 2)) (singleton (2, 3)) = singleton (1, 3).
  apply functional_extensionality.
  intro x.
  destruct x as (a, b).
  apply H.
  compute.
  split.
  intro.
  destruct H0.
  destruct H0.

Admitted.

Goal *)*)
End Nfa.

Section Test.

Definition next1 (a s : nat) : set nat :=
  match a, s with
  | 0, 0 => [1]
  | 1, 1 => [1]
  | _, _ => []
  end.

Definition nfa1 :=
  mkNfa
    (0)
    next1
    ([1]).

Goal accepts eq_nat_dec nfa1 [0] = true.
  auto.
Qed.

Goal accepts eq_nat_dec nfa1 [0; 1] = true.
  auto.
Qed.

End Test.


From KapCake Require Export mathcomp_ext.
From mathcomp Require Export finmap.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Local Open Scope fset.
Local Open Scope fmap.

Coercion fset_sub_finType : finSet >-> finType.

(* Finite sets *)
Section FinSet.
Variable (T : choiceType).
Implicit Types (A B C : {fset T}) (x : T).

(* two lemmas from finmap_plus.v in graph-theory/theories/core *)
Lemma fsetDl A B x :
  x \in A `\` B -> x \in A.
Proof using Type. by case/fsetDP. Qed.

Lemma in_fsep A (P : pred T) x :
  x \in [fset y | y in A & P y] = (x \in A) && (P x).
Proof using Type.
  apply/imfsetP/andP => /= [[y]|[H1 H2]];
    first by rewrite inE => /andP[H1 H2] ->.
  exists x => //. by rewrite inE H1.
Qed.

Lemma fsetD_negb A (P : pred T) :
  [fset x in A | ~~(P x)] = A `\` [fset x in A | P x].
Proof using Type.
  apply/fsetP => x. apply/imfsetP/fsetDP.
  move=> [y H ->]. move: H. rewrite !inE => /andP[H1 H2] //.
  split=> //. rewrite negb_and. apply/orP. by right.
  move=> [xIX xNIfsetP]. exists x => //=. rewrite !inE.
  apply/andP. split=> //. apply/negP => HP. apply/negP: xNIfsetP.
  rewrite negbK in_fsep. apply/andP. by split.
Qed.

Lemma val_fsubset_in (U X : {fset T}) (A : {fset U}) :
  val @` A `<=` X ->
  forall x : U, x \in A -> val x \in X.
Proof using Type.
  move=> /fsubsetP H x xIA. apply: (H (val x)).
  apply/imfsetP. by exists x.
Qed.

Lemma val_fsubset_notin (U X : {fset T}) (A : {fset U}) :
  ~~ (val @` A `<=` X) ->
  (exists a : U, a \in A /\ val a \notin X).
Proof using Type.
  move=> /fsubsetPn[a /imfsetP[y yIA aEy] aNIX].
  exists y. split=> //. by rewrite -aEy.
Qed.

Lemma fset_eq_in A B (AEB : A = B) x : (x \in A) = (x \in B).
Proof using Type.
  move/eqP: AEB. rewrite eqEfsubset => /andP[AIB BIA].
  apply/idP/idP; by apply: fsubsetP.
Qed.

Lemma fset_eq_inLR A B (AEB : A = B) x : (x \in A) -> (x \in B).
Proof using Type.
  move/eqP: AEB. rewrite eqEfsubset => /andP[AIB BIA].
  by apply: fsubsetP.
Qed.

Lemma fset_eq_inRL A B (AEB : A = B) x : (x \in B) -> (x \in A).
Proof using Type.
  move/eqP: AEB. rewrite eqEfsubset => /andP[AIB BIA].
  by apply: fsubsetP.
Qed.

Lemma fsubset_trans B A C :
  A `<=` B -> B `<=` C -> A `<=` C.
Proof using Type.
  move=> /fsubsetP AsubB /fsubsetP BsubC.
  apply/fsubsetP => x xIA. apply: BsubC. by apply: AsubB.
Qed.

Lemma eq_fsubsetLR A B : A = B -> A `<=` B.
Proof using Type. move/eqP. by rewrite eqEfsubset => /andP[H _]. Qed.

Lemma eq_fsubsetRL A B : A = B -> B `<=` A.
Proof using Type. move/eqP. by rewrite eqEfsubset => /andP[_ H]. Qed.

Definition preimage_of (A : finType) (B : eqType)
  (f : {ffun A -> B}) (v : B) : {fset A} :=
  [fset k : A | f k == v].
Notation "f ^-1 v" := (preimage_of f v)
                        (at level 70, right associativity).

End FinSet.

(* Finite maps *)
Section FinMap.
Variables (K V : choiceType).
Implicit Types (f g : {fmap K -> V}) (v : V).

Lemma codomf_cat f g :
  codomf (f + g) = codomf g `|` codomf f.[\domf g].
Proof using Type.
  apply/fsetP => v. rewrite ![RHS]inE.
  apply/codomfP/(orPP (codomfP _ _) (codomfP _ _)); last first.
  - move=> [] [x xI]; exists x; rewrite fnd_cat.
    + by case: fndP xI.
    + move: xI. rewrite fnd_rem. by case: ifP.
  - move=> [] x. rewrite fnd_cat. case: fndP => // [xg gx|xNg fx].
    + left. exists x. by rewrite in_fnd.
    + right. exists x. by rewrite fnd_rem ifN.
Qed.

Lemma codomf_const (ks : {fset K}) v :
  ks != fset0 -> codomf [fmap _ : ks => v] = [fset v].
Proof using Type.
  move=> /fset0Pn [k k_in_ks]. apply/fsetP=> w.
  apply/codomfP/imfsetP. move=> [l /fndSomeP[lf H]].
  exists w => //. by rewrite inE -H ffunE.
  move=> [x /[!inE]/eqP H] ->. exists k. apply/fndSomeP.
  exists k_in_ks. by rewrite H ffunE.
Qed.

Lemma in_codomf_fset f (P : pred K) v :
  v \in [fset f k | k : domf f & P (val k)] =
  [exists k : domf f, (f k == v) && P (val k)].
Proof using Type.
  apply/imfsetP/existsP. move=> [k /[!inE]/andP[_ H1]] /eqP H2.
  exists k. by rewrite eq_sym H2 H1.
  (* second part *)
  move=> [k /andP[/eqP H HP]]. exists k. by rewrite !inE HP.
  by rewrite H.
Qed.

Lemma fsubset_cat (A : {fset K}) f g :
  A `<=` domf f -> A `<=` domf (f + g).
Proof using Type.
  move=> /fsubsetP Asub_domf. apply/fsubsetP => k kIA.
  move: (Asub_domf k kIA) => kIdomf.
  by rewrite !inE kIdomf.
Qed.

(* Similar to in_codomf but it works on `k \in domf f` *)
(* instead of a value of type `domf f`. *)
(* Lemma im f (k : K) (kId : k \in domf f) : f.[kId] \in codomf f. *)
(* Proof using Type. by apply: in_codomf. Qed. *)
(* Definition im' f (k : domf f) : codomf f := [`in_codomf k]. *)

End FinMap.
Section Composition.
Variables (K V1 V2 : choiceType)
  (f : {fmap K -> V1}) (g : {fmap V1 -> V2})
  (fcodIgdom : codomf f `<=` domf g).

Definition fcomp : {fmap K -> V2} :=
  [fmap x : domf f =>
     g.[fsubsetP fcodIgdom _ (in_codomf x)]].

Lemma fcomp_domf : domf fcomp = domf f.
Proof using Type. done. Qed.

Lemma fcomp_codomf : codomf fcomp `<=` codomf g.
Proof using Type.
  apply/fsubsetP => v2. move/codomfP => [k /fndSomeP[kIf fckEv2]].
  rewrite -fckEv2 ffunE. apply: in_codomf.
Qed.

Lemma fdecomp (k : K) :
    fcomp.[? k] = if f.[? k] is Some fk then g.[? fk] else None.
Proof using Type.
  rewrite /fcomp /fnd /omap /obind /oapp.
  case: insubP => //= x xIf xEk. rewrite insubT.
  apply: fsubsetP. apply: fcodIgdom. by apply: in_codomf.
  move=> fxIg. congr Some. rewrite ffunE. by apply: eq_getf.
Qed.

End Composition.
Section CompositionOf2.
Variables (K V1 V2 : choiceType)
  (f : {fmap K -> V1}) (g : {fmap V1 -> V2})
  (fcodIgdom : codomf f `<=` domf g).

Section Pre.
Variables (f' : {fmap K -> V1})
  (f'codIgdom : codomf f' `<=` domf g).

Lemma fcomp_eqf (fEf' : f = f') (k : K) :
  (fcomp fcodIgdom).[? k] = (fcomp f'codIgdom).[? k].
Proof using Type. by rewrite !fdecomp fEf'. Qed.
End Pre.

Section Post.
Variables (g' : {fmap V1 -> V2})
  (fcodIg'dom : codomf f `<=` domf g').

Lemma fcomp_eqg (gEg' : g = g') (k : K) :
  (fcomp fcodIgdom).[? k] = (fcomp fcodIg'dom).[? k].
Proof using Type. by rewrite !fdecomp gEg'. Qed.

End Post.
End CompositionOf2.
Section CompositionOf3.
Variables (K V1 V2 V3 : choiceType)
  (f : {fmap K -> V1}) (g : {fmap V1 -> V2}) (h : {fmap V2 -> V3})
  (fcodIgdom : codomf f `<=` domf g)
  (gcodIhdom : codomf g `<=` domf h)
  (fgcodIhdom : codomf (fcomp fcodIgdom) `<=` domf h)
  (fcodIghdom : codomf f `<=` domf (fcomp gcodIhdom)).

Lemma fcompA (k : K) :
  (@fcomp K V1 V3 f (fcomp gcodIhdom) fcodIghdom).[? k] =
  (@fcomp K V2 V3 (fcomp fcodIgdom) h fgcodIhdom).[? k].
Proof using Type.
  rewrite !fdecomp. case: f.[? k] => // v1. by rewrite fdecomp.
Qed.

End CompositionOf3.

Record funlike (K V : finType) := { fn : {ffun K -> V} }.
(* | Fun (f : K -> V) *)
(* | FFun of {ffun K -> V}. *)
(* | FMap (f : {fmap K -> V}). *)
(* Coercion fun_to_funlike (f : K -> V) := Fun f. *)
Coercion ffun_to_funlike (K V : finType) (f : {ffun K -> V}) :=
  {| fn := f |}.
Coercion fmap_to_funlike (K V : choiceType) (f : {fmap K -> V}) :=
  {| fn := [ffun k : domf f => [`in_codomf k]] |}.

Definition comp (K V W : finType) (f : funlike K V) (g : funlike V W)
  : funlike K W := {| fn := (fn f) \c (fn g) |}.

(* Notation "[ x ; f1 ]" := (fn f1 x). *)
(* Notation "[ x ; f1 ; .. ; fi ; fj ]" := *)
(*   (fn (comp f1 .. (comp fi fj) ..) x). *)
Notation "[ f1 ; .. ; fi ; fj ]" :=
  (fn (comp f1 .. (comp fi fj) ..)).