(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                            2004 -2005                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Require Export lambda_bruijn.
Set Implicit Arguments.
Parameter E:Set.
Parameter intent:Type ->Type.
Notation "'s->' ty":=(intent ty)(at level 40).

(* it can be seen as the application from all possible worlds to the
 data structure *)
Parameters box_coq diam_coq:forall (A:Type), A->intent A.
Parameters debox_coq dediam_coq:forall (A:Type), intent A->A.

(* interpretation of semType *)

Fixpoint trans_type (st:semType):Type:=
match st with
|e=>E
|t=> Prop
|funAppli t1 t2=> (trans_type t1)->(trans_type t2)
|cartProd t1 t2=>prodT (trans_type t1)(trans_type t2)
|intention t1=>intent (trans_type t1)
end.

Inductive type_obj:Type:=
|obj1:forall (A:Type),A-> type_obj.

(* generalization of list for sort type *)
Inductive listT (A:Type):Type:=
|nilT:listT A
|consT:A->listT A->listT A.

Implicit Arguments nilT [A].

Inductive trans_env:list semType->listT (type_obj)->
                          Type:=
|nil_trans:trans_env nil nilT
|cons_trans:forall l1 l2 a1 (x1:trans_type a1),
                             trans_env  l1 l2->
                             trans_env  (a1::l1)(consT (obj1 x1)l2).

Inductive optionT (A : Type) : Type:=
  SomeT : A -> optionT A | NoneT : optionT A.

Implicit Arguments NoneT [A].

Fixpoint nth_error_T (A:Type)(l:listT A)(n:nat){struct l}:optionT A:=
match l, n with
|nilT, _ => NoneT
|consT a1 l1, 0=>SomeT a1
|consT a1 l1, (S m)=>nth_error_T l1 m
end.

Definition trans_env_nth:forall (e:list semType)(lit:listT type_obj),
                       trans_env e lit->
                       forall n t,  nth_error e n=Some t->
                        (sigT (fun x1:trans_type t=> nth_error_T lit n=SomeT
                         (obj1 x1))).
 induction 1.
 intro n; case n; simpl in |- *.
 discriminate 1.
 discriminate 2.
 intro n; case n; simpl in |- *.
 injection 1; intros; subst; econstructor; eauto.
 auto.
Defined.

Section coq_terms.
Variable  X:Set.
Variable getSemTypeX : X->semType.
Variable consts:forall (x:X), trans_type (getSemTypeX x).

Definition trans_lamb:forall l env t,
   isWellTyped getSemTypeX env l t->
   no_hyps_inside l->
  forall (vars:listT type_obj),
       trans_env env vars->
       (trans_type t).
 induction 1; intros.
 elim (trans_env_nth X0 _ e).
 intros x H2; exact x.
 exact (consts x).
 simpl in H.
 elim H.
 simpl in H1.
 decompose [and] H1.
 simpl in IHisWellTyped1.
 exact (IHisWellTyped1 H2 _ X0 (IHisWellTyped2 H3 _ X0)).
 simpl in |- *.
 simpl in H0; generalize H H0 IHisWellTyped;clear H H0 IHisWellTyped.
 case t2.
 intros H H0 H1 x.
 apply (H1 H0 (consT (obj1 x) vars)).
 apply cons_trans;auto.
 intros H H0 H1 P.
 apply (H1 H0 (consT (obj1 P) vars)).
 apply cons_trans;auto.
 intros s s0 H0 H1 H2 Q.
apply (H2 H1 (consT (obj1 Q) vars)).
 constructor;auto.
 intros s s0 H0 H1 H2 C.
apply (H2 H1 (consT (obj1 C) vars)).
 constructor;auto.
 intros s H0 H1 H2 T.
apply (H2 H1 (consT (obj1 T) vars)).
 constructor;auto.
 simpl in |- *.
 simpl in H1.
 decompose [and] H1.
 constructor.
 exact (IHisWellTyped1 H2 _ X0).
 exact (IHisWellTyped2 H3 _ X0).
 simpl in H0.
 simpl in IHisWellTyped.
 exact (fstT (IHisWellTyped H0 _ X0)).
 simpl in H0; simpl in IHisWellTyped.
 exact (sndT (IHisWellTyped H0 _ X0)).
 simpl in |- *.
 simpl in H0.
 exact (box_coq (IHisWellTyped H0 _ X0)).
 simpl in H0.
 simpl in IHisWellTyped.
 exact (debox_coq (IHisWellTyped H0 _ X0)).
 simpl in |- *; simpl in H0.
 exact (diam_coq (IHisWellTyped H0 _ X0)).
 simpl in H0.
 simpl in IHisWellTyped.
 exact (dediam_coq (IHisWellTyped H0 _ X0)).
Defined.

Definition trans_lamb0:forall l env t,
   type_check getSemTypeX env l=Some t->
   no_hyps_inside l->
  forall (vars:listT type_obj),
       trans_env env vars->
       (trans_type t).

 intro l; elim l; intros.
 simpl in H; elim (trans_env_nth X0 _ H).
 intros x H2; exact x.
 simpl in H.
 injection H; intro; subst.
 exact (consts x).
 simpl in H0; tauto.
 elim (getTypeAppl _ _ _ _ H).
 intros x H1; decompose [and] H1; clear H1.
 generalize (X0 env _ H2); clear X0; simpl in |- *; intro X0.
 simpl in H0; decompose [and] H0; clear H0.
 exact (X0 H1 _ X2 (X1 _ _ H3 H4 _ X2)).
 simpl in H0.
 elim (getTypeAbs _ _ _ _ H).
 intros x H3; decompose [and] H3; clear H3; subst.
 simpl in |- *; intro.
 apply (X0 _ _ H2 H0 (consT (obj1 X2) vars)).
 constructor; auto.
 simpl in H0; decompose [and] H0; clear H0.
 elim (getTypeTwoL _ _ _ _ H).
 intros x H3; decompose [and sig] H3; clear H3.
 subst.
 simpl in |- *.
 split.
 exact (X0 env x H5 H1 _ X2).
 exact (X1 env _ H6 H2 _ X2).
 elim (getTypePi1 _ _ _ H).
 intros x H3.
 simpl in H0.
 exact (fstT (X0 _ _ H3 H0 _ X1)).
 simpl in H0; elim (getTypePi2 _ _ _ H); intros x H3.
 exact (sndT (X0 _ _ H3 H0 _ X1)).
 elim (getTypeBox _ _ _ H).
 intros x H3; decompose [and] H3; clear H3; subst.
 simpl in H0.
 exact (box_coq (X0 _ _ H2 H0 _ X1)).
 simpl in H0.
 exact (debox_coq (X0 _ _ (getTypeDebox _ _ _ H) H0 _ X1)).
 simpl in H0.
 elim (getTypeDiam _ _ _ H).
 intros x H3; decompose [and] H3; clear H3.
 subst.
 simpl in |- *.
 exact (diam_coq (X0 _ _ H2 H0 _ X1)).
 simpl in H0.
 exact (dediam_coq (X0 _ _ (getTypeDediam _ _ _ H) H0 _ X1)).
Defined.

Definition pretty_printer0 (l:lambda_terms X)(ty:semType)
(p:type_check getSemTypeX nil l =Some ty) (q:no_hyps_inside l) :(trans_type ty):=
(trans_lamb0 _ p q (nil_trans)).

(*
(* tests *)
Definition wty:type_check getSemTypeX nil (abs e (abs e (box(pi1 (twoL
(num _ 0) (num _
1))))))=Some (funAppli e (funAppli e (intention e))).
simpl;auto.
Qed.

Definition wty1:isWellTyped getSemTypeX nil (abs e (abs e (box(pi1 (twoL
(num _ 0) (num _
1)))))) (funAppli e (funAppli e (intention e))).
constructor.
constructor.
econstructor.
econstructor.
constructor.
constructor.
auto.
econstructor;simpl;eauto.
Defined.

Definition noHyps0:no_hyps_inside (abs e (abs e (box(pi1 (twoL (num X 0) (num
_ 1)))))).
simpl;auto.
Defined.

Eval compute in (pretty_printer0 _  wty noHyps0).

Eval compute in (trans_lamb1 wty1 noHyps0 (nil_trans)).*)
End coq_terms.

(*
Section deriv_coq.
Variable gr:syn_sem_gram.
Variable l:list (gr.(lexic)).(W).
Variable f:Form (gr.(lexic)).(I) (gr.(lexic)).(J)
(gr.(lexic)).(A).
Variable E:Set. (* interpretation of e *)
Variable intent:Set ->Set.
Variables box_coq diam_coq:forall (A:Set), A->intent A.
Variables debox_coq dediam_coq:forall (A:Set), intent A->A.
Variable consts:forall (x:word_type (gr.(lexic)).(W)),
trans_type E intent (getTypeWT x).

Variable red:deriveTo gr l f.

Hypothesis no_hyps:no_hyps_inside (getSemantic red).

Definition get_deriv_coq:trans_type E intent (mapExt
(gr.(lexic)).(map) f).
eapply trans_lamb with (l := getSemantic red).
 exact box_coq.
 exact diam_coq.
 exact debox_coq.
 exact dediam_coq.
 eexact consts.
 apply wellTyped_type_check.
 case red.
 simpl in |- *.
 intros.
 apply wellTypedSem.
 auto.
 constructor 1.
Defined.

End deriv_coq.
*)


Require Import SpecCert.Formalism.
Require Import SpecCert.Smm.Delta.Delta_def.
Require Import SpecCert.Smm.Delta.Preserve.
Require Import SpecCert.Smm.Delta.Secure.
Require Import SpecCert.Smm.Software.
Require Import SpecCert.x86.

Theorem delta_is_sound: forall init last: Architecture Software,
    sound_mechanism (init:=init)(last:=last) Delta smm_secure.
Proof.
  unfold sound_mechanism.
  intros init last.
  induction r.
  + unfold sound_mechanism, compliant_run, behavior_enforced_step, smm_secure, software_execution_isolation.
    intros [Hinv Hbehave].
    inversion Hst as [Hpre Hpost].
    apply (invariant_permits_security ev init last Hinv Hpre Hpost).
  + intro Hcomp.
    apply compliant_run_unwrap in Hcomp.
    assert (state_inv Delta penultimate) as Hinv'; [apply (compliant_run_preserves_inv Delta r Hcomp)|].
    assert (smm_secure r) as Hsec; [apply IHr in Hcomp; exact Hcomp|].
    unfold smm_secure, software_execution_isolation.
    split.
    * exact Hsec.
    * inversion Hst as [Hpre Hpost].
      apply (invariant_permits_security ev penultimate last Hinv' Hpre Hpost).
Qed.


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

(**********************************************************************)
(*                         Wave_Types.v                               *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Omega Max Bool List.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Wave_as_SF.SF_Terms.
Require Import IntensionalLib.Wave_as_SF.SF_Tactics.
Require Import IntensionalLib.Wave_as_SF.SF_reduction.
Require Import IntensionalLib.Wave_as_SF.SF_Normal.
Require Import IntensionalLib.Wave_as_SF.SF_Closed.
Require Import IntensionalLib.Wave_as_SF.Substitution.
Require Import IntensionalLib.Wave_as_SF.SF_Eval.
Require Import IntensionalLib.Wave_as_SF.Star.
Require Import IntensionalLib.Wave_as_SF.Fixpoints.
Require Import IntensionalLib.Wave_as_SF.Wave_Factor.
Require Import IntensionalLib.Wave_as_SF.Wave_Factor2.
Require Import IntensionalLib.Wave_as_SF.Equal.
Require Import IntensionalLib.Wave_as_SF.Extensions.

(* the plan

Old approach T :: = Leaf  | Stem T | Fork T T | T -> T

Fork Leaf T < K T
Fork (Stem (U-> V)) (U-> V -> T) < U -> T
Fork (Fork P Q) T < (P-> Q-> U) -> U

New approach:

 - types are terms

t : T   u : U
-----------------
t u : T U

Here, T is a function that is applied to U.
If type-checking fails then T U returns an error, say, ~

Let E be the equality function. Define

U -> V = \*x. EUxV~
       = S(S(EU)(KV))(K~)
       =  ~(~(K~))(~(~(KV))(EU))

so that (U -> V) U' -->  EUU'V~  (the final ~ is the error).

~ : Node  where Node is a (non-recursive) function that satisfies

Node Node T U --> T
Node (Node (U -> V)) (U -> V -> T) U --> T
Node (Node P Q) T (P-> Q-> U) -> U

Now, Node P Q must be a function,
so that it can be passed as an argument in, say Node (U-> V).
So Node is unary or binary. Simplest is unary.
Thus Node is a pattern-matching function which, in general,
produces pattern-matching functions as results.

To Do:

Define R
Define E.
Define the pattern-matching functions in the result of Node.
Determine the patterns for Node (U->V) and Node P Q.
Define Node (some circularity here ?!)

Define Node

*)

Definition Funty U T := star_opt (App (App (App (App equal_comb (lift 1 U)) (Ref 0)) (lift 1 T)) (Op Node)).

Lemma funty_ok :
forall U T, program U -> sf_red (App (Funty U T) U) T.
Proof.
intros. unfold Funty.
eapply transitive_red. eapply2 star_opt_beta.
unfold subst, lift; rewrite ! subst_rec_app.
rewrite subst_rec_closed. 2: rewrite equal_comb_closed; omega.
rewrite ! subst_rec_lift_rec; try omega.
rewrite lift_rec_null. unfold subst_rec. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
eapply transitive_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 equal_programs. all: auto.
eval_tac.
Qed.

Lemma funty_fail:
forall U V T, program U -> program V -> U <> V -> sf_red (App (Funty U T) V) (Op Node).
Proof.
intros. unfold Funty.
eapply transitive_red. eapply2 star_opt_beta.
unfold subst, lift; rewrite ! subst_rec_app.
rewrite subst_rec_closed. 2: rewrite equal_comb_closed; omega.
rewrite ! subst_rec_lift_rec; try omega.
rewrite lift_rec_null. unfold subst_rec. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
eapply transitive_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 unequal_programs. all: auto.
eval_tac. eval_tac.
Qed.

Definition Nty :=

extension (Op Node) k_op (
extension (App (App (Op Node) (Ref 0)) (Ref 1))
          (App k_op (extension (Funty (Ref 0) (Funty (Ref 1) (Ref 2)))
                               (App (App (App (App equal_comb (Ref 4)) (Ref 2))
                               (App (App (App (App equal_comb (Ref 3)) (Ref 1))
                                         (Ref 0))
                               (Op Node))) (Op Node)) (App k_op (Op Node)))) (
extension (App (Op Node) (Funty (Ref 0) (Ref 1)))
          (extension (Funty (Ref 0) (Funty (Ref 1) (Ref 2)))
                               (App (App (App (App equal_comb (Ref 4)) (Ref 2))
                               (App (App (App (App equal_comb (Ref 3)) (Ref 1))
                                         (Funty (Ref 2) (Ref 0)))
                               (Op Node))) (Op Node))
                      (App k_op (Op Node)))
           (App k_op (Op Node))))
.

Inductive derive : SF -> SF -> Prop :=
| op_ty : derive (Op Node) Nty
| app_ty : forall t T u U, derive t T -> derive u U -> derive (App t u) (App T U)
| red_ty : forall t T0 T, derive t T0 -> sf_red T0 T -> derive t T.

Lemma derive_K : derive k_op

(App

extension  < dynamic pattern >

Node Node T U --> T
Node (Node (U -> V)) (U -> V -> T) U --> T
Node (Node P Q) T (P-> Q-> U) -> U


(**************************************************************************)
(*  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 2014: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

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

Module Make(Import M: Memory.T).

 Inductive empty_set : Set :=.

 Inductive term: Type -> Type -> Type :=
  | comp:   forall {X Y Z: Type}, term X Y -> term Y Z -> term X Z
  | pair: forall {X Y Z: Type}, term X Z -> term Y Z -> term (X*Y) Z
  | copair: forall {X Y Z}, term Z X -> term Z Y -> term Z (X+Y)
  | tpure:  forall {X Y: Type}, (X -> Y) -> term Y X
  | lookup: forall i:Loc, term Z unit
  | update: forall i:Loc, term unit Z.

 Infix "o" := comp (at level 70).

End Make.


(** * Exponential laws about the terminal category *)
Require Import Category.Core Functor.Core FunctorCategory.Core Functor.Identity NaturalTransformation.Core Functor.Paths NaturalTransformation.Paths ExponentialLaws.Law1.Functors Functor.Composition.Core.
Require Import InitialTerminalCategory.Core.
Require Import Basics.Trunc HoTT.Tactics ExponentialLaws.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope functor_scope.

(** ** [C¹ ≅ C] *)
Section law1.
  Context `{Funext}.
  Context `{IsInitialCategory zero}.
  Context `{IsTerminalCategory one}.
  Local Notation "0" := zero : category_scope.
  Local Notation "1" := one : category_scope.

  Variable C : PreCategory.

  Definition helper (c : Functor 1 C)
  : Functors.from_terminal C (c (center _)) = c.
  Proof.
    path_functor.
    exists (path_forall _ _ (fun x => ap (object_of c) (contr _))).
    abstract (
        exp_laws_t;
        simpl;
        rewrite <- identity_of;
        f_ap;
        symmetry;
        apply contr
      ).
  Defined.

  Lemma law
  : @functor _ one _ C o inverse C = 1
    /\ inverse C o @functor _ one _ C = 1.
  Proof.
    split;
    path_functor.
    exists (path_forall _ _ helper).
    unfold helper.
    exp_laws_t.
  Qed.
End law1.


Load "DH_AUTH".

(******dec of encryption is plaintext****)

Axiom dep_enc :  forall(n:nat) (x z :message), (dec (enc x (pk n) z) (sk n)) # x.

Notation "  l '[[' n ']]' " := ((var_free_mylist n l) = true) (at level 0).

(*********check if sk(n) occurs only at dec postion ******************)

(*********************In a term : message and Bool********)
Fixpoint  skn_in_dec_bol (n : nat )(t:Bool) : bool :=
 match t with
| Bvar n' => true
| FAlse => true
| TRue => true
| EQ_B  b1 b2 =>  (andb ( skn_in_dec_bol n b1)  (skn_in_dec_bol n b2))
| EQ_M t1 t2 => andb (skn_in_dec_msg n t1) ( skn_in_dec_msg n t2)
| if_then_else_B t1 t2 t3 => andb ( skn_in_dec_bol n t1)  (andb (skn_in_dec_bol n t2)(skn_in_dec_bol n t3) )
| EQL t1 t2 => andb (skn_in_dec_msg n t1) ( skn_in_dec_msg n t2)
| ver t1 t2 t3 => (andb  (andb (skn_in_dec_msg n t1) (skn_in_dec_msg n t2)) (skn_in_dec_msg n t3))
 end
with skn_in_dec_msg (n : nat )(t:message) : bool :=
 match t with
| if_then_else_M b3 t1 t2 => andb (skn_in_dec_bol n b3) (andb ( skn_in_dec_msg n  t1)(skn_in_dec_msg n t2))
| (Mvar n') =>  if (beq_nat n' n) then false else true
| O => true
| acc => true
| N n'=> true
|new => true
| exp t1 t2 t3 => andb ( skn_in_dec_msg n t1) (andb (  skn_in_dec_msg  n t2) ( skn_in_dec_msg n t3))
| pair t1 t2 => andb (  skn_in_dec_msg n t1) (  skn_in_dec_msg n t2)
| pi1 t1 => (  skn_in_dec_msg n t1)
| pi2 t1 => match t1 with
             | k t2 => match t2 with
                       | N n' => if (beq_nat n' n) then false else true
                       | _ => true
                         end
             | _ => true

               end

| ggen t1 => (  skn_in_dec_msg n t1)
| act t1 => (  skn_in_dec_msg n t1)
| rr n' =>  true
| rs t1 => ( skn_in_dec_msg n t1)
| L t1 => ( skn_in_dec_msg n t1)
| m t1 => ( skn_in_dec_msg n t1)
|enc t1 t2 t3 =>  andb (  skn_in_dec_msg n t1) (andb (  skn_in_dec_msg n t2) (  skn_in_dec_msg n t3))
|dec t1 t2 => match t2 with
             | (pi2 (k (N n'))) => if (beq_nat n' n) then (andb true (skn_in_dec_msg n t1))  else true
             | t2' => (skn_in_dec_msg n t1)
              end
| k t1 => (skn_in_dec_msg n t1)
| nonce t1 => (skn_in_dec_msg n t1)
| to t1 => (skn_in_dec_msg n t1)
| reveal t1 => ( skn_in_dec_msg n t1)
| sign t1 t2 => (andb ( skn_in_dec_msg n t1) ( skn_in_dec_msg n t2))
| i n' => true

| f  l => (@forallb message (skn_in_dec_msg n) l)

end.

(*******************************************)

Eval compute in skn_in_dec_msg 1 (k(N 1)).
Eval compute in skn_in_dec_msg 1 ((pi2(k (N 1)))  ).

Eval compute in skn_in_dec_msg 1 (r  2).
(*********In a term os*****************************)

Definition skn_in_dec_os (n:nat)(t:oursum): bool :=
match t with
|bol b => skn_in_dec_bol n b
|msg t => skn_in_dec_msg n t
end.

(**** In a message list: ilist message n********)

Fixpoint skn_in_dec_mlist {m:nat}(x:nat) (ml : ilist message m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (skn_in_dec_msg x h) (skn_in_dec_mlist x ml1))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint skn_in_dec_blist {m:nat}(x:nat) (ml : ilist Bool m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (skn_in_dec_bol x h) (skn_in_dec_blist x ml1))
end.

(********In a mylist : mylist n********)

Fixpoint skn_in_dec_mylist {m:nat}(x:nat) (ml :  mylist m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (skn_in_dec_os x h) (skn_in_dec_mylist x ml1))
end.

(**********************************************)
(********************To check if a term sk(n) doesn't occur *********)

(*********************In a term : message and Bool********)
Fixpoint  notocc_skn_bol (n:nat) (t:Bool) : bool :=
 match t with
| Bvar n' =>  true
| FAlse => true
| TRue => true
| EQ_B  b1 b2 =>  (andb ( notocc_skn_bol n b1)  (notocc_skn_bol n b2))
| EQ_M t1 t2 => andb (notocc_skn_msg n t1) ( notocc_skn_msg n t2)
| if_then_else_B t1 t2 t3 => andb ( notocc_skn_bol n t1)  (andb (notocc_skn_bol n t2)(notocc_skn_bol n t3) )
| EQL t1 t2 => andb (notocc_skn_msg n t1) ( notocc_skn_msg n t2)
| ver t1 t2 t3 => (andb  (andb (notocc_skn_msg n t1) (notocc_skn_msg n t2)) (notocc_skn_msg n t3))
 end
with notocc_skn_msg (n:nat) (t:message) : bool :=
 match t with
| if_then_else_M b3 t1 t2 => andb (notocc_skn_bol n b3) (andb ( notocc_skn_msg n  t1)(notocc_skn_msg n t2))
| (Mvar n') =>  true
| O => true
| acc => true
| N n'=> true
|new => true
| exp t1 t2 t3 => andb ( notocc_skn_msg n t1) (andb (  notocc_skn_msg  n t2) ( notocc_skn_msg n t3))
| pair t1 t2 => andb (  notocc_skn_msg n t1) (  notocc_skn_msg n t2)
| pi1 t1 => (  notocc_skn_msg n t1)
| pi2 t1 => match t1 with
             | k (N n') => if (beq_nat n' n) then false else true
             | _ => true

               end

| ggen t1 => (  notocc_skn_msg n t1)
| act t1 => (  notocc_skn_msg n t1)
| rr n' => true
| rs t1 => ( notocc_skn_msg n t1)
| L t1 => ( notocc_skn_msg n t1)
| m t1 => ( notocc_skn_msg n t1)
|enc t1 t2 t3 =>  andb (  notocc_skn_msg n t1) (andb (  notocc_skn_msg n t2) (  notocc_skn_msg n t3))
|dec t1 t2 => andb (notocc_skn_msg n t1) (notocc_skn_msg n t2)
| k t1 => (notocc_skn_msg n t1)
(*
| pk t1 => ( notoccur_msg n t1)
| sk t1 => ( notoccur_msg n t1)
*)
| nonce t1 => (notocc_skn_msg n t1)
 | to t1 => (notocc_skn_msg n t1)
| reveal t1 => ( notocc_skn_msg n t1)
| sign t1 t2 => (andb ( notocc_skn_msg n t1) ( notocc_skn_msg n t2))
| i n' => true

| f  l => (@forallb message (notocc_skn_msg n) l)

end.

(***********************************************)
(*******************************************)

Eval compute in notocc_skn_msg 1 ((pi2(k (N 2)))  ).

(*********In a term os*****************************)

Definition notocc_skn_os (n:nat)(t:oursum): bool :=
match t with
|bol b => notocc_skn_bol n b
|msg t => notocc_skn_msg n t
end.

(**** In a message list: ilist message n********)

Fixpoint notocc_skn_mlist {m:nat}(x:nat) (ml : ilist message m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (notocc_skn_msg x h) (notocc_skn_mlist x ml1))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint notocc_skn_blist {m:nat}(x:nat) (ml : ilist Bool m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (notocc_skn_bol x h) (notocc_skn_blist x ml1))
end.

(********In a mylist : mylist n********)

Fixpoint notocc_skn_mylist {m:nat}(x:nat) (ml :  mylist m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (notocc_skn_os x h) (notocc_skn_mylist x ml1))
end.

(********************To check if a term dec(t , sk(n)) doesn't occur *********)

(*********************In a term : message and Bool********)
Fixpoint  notocc_dec_bol (n:nat) (t:message)(k:Bool) : bool :=
 match k with
| Bvar n' =>  true
| FAlse => true
| TRue => true
| EQ_B  b1 b2 =>  (andb ( notocc_dec_bol n t b1)  (notocc_dec_bol n t b2))
| EQ_M t1 t2 => andb (notocc_dec_msg n t t1) ( notocc_dec_msg n t t2)
| if_then_else_B t1 t2 t3 => andb ( notocc_dec_bol n t t1)  (andb (notocc_dec_bol n t t2)(notocc_dec_bol n t t3) )
| EQL t1 t2 => andb (notocc_dec_msg n t t1) ( notocc_dec_msg n t t2)
| ver t1 t2 t3 => (andb  (andb (notocc_dec_msg n t t1) (notocc_dec_msg n t t2)) (notocc_dec_msg n t t3))
 end
with notocc_dec_msg (n:nat) (t:message) (k:message) : bool :=
 match k with
| if_then_else_M b3 t1 t2 => andb (notocc_dec_bol n t b3) (andb ( notocc_dec_msg n t  t1)(notocc_dec_msg n t t2))
| (Mvar n') =>  true
| O => true
| acc => true
| N n'=> true
|new => true
| exp t1 t2 t3 => andb ( notocc_dec_msg n t t1) (andb (  notocc_dec_msg  n t t2) ( notocc_dec_msg n t t3))
| pair t1 t2 => andb (  notocc_dec_msg n t t1) (  notocc_dec_msg n t t2)
| pi1 t1 => (  notocc_dec_msg n t t1)
| pi2 t1 => (notocc_dec_msg n t t1)
| ggen t1 => (  notocc_dec_msg n t t1)
| act t1 => (  notocc_dec_msg n t t1)
| rr n' => true
| rs t1 => ( notocc_dec_msg n t t1)
| L t1 => ( notocc_dec_msg n t t1)
| m t1 => ( notocc_dec_msg n  t t1)
|enc t1 t2 t3 =>  andb (  notocc_dec_msg n t t1) (andb (  notocc_dec_msg n t t2) (  notocc_dec_msg n t t3))
|dec t1 t2 =>  match t1 , t2  with
              | t , pi2(k (N n')) => if (beq_nat n' n) then false else true
              | _ , _ => true

                   end

| k t1 => (notocc_dec_msg n t t1)
(*
| pk t1 => ( notoccur_msg n t1)
| sk t1 => ( notoccur_msg n t1)
*)
| nonce t1 => (notocc_dec_msg n t t1)
 | to t1 => (notocc_dec_msg n t t1)
| reveal t1 => ( notocc_dec_msg n t t1)
| sign t1 t2 => (andb ( notocc_dec_msg n t t1) ( notocc_dec_msg n t t2))
| i n' => true

| f  l => (@forallb message (notocc_dec_msg n t) l)

end.

(***********************************************)
(*******************************************)

Eval compute in notocc_dec_msg 1 O (dec _ (pi2 (k (N 1)))).

(*********In a term os*****************************)

Definition  notocc_dec_os (n:nat)(t:message)(k:oursum): bool :=
match k with
|bol b => notocc_dec_bol n t b
|msg t1 => notocc_dec_msg n t t1
end.

(**** In a message list: ilist message n********)

Fixpoint notocc_dec_mlist (x:nat) (t:message) (ml : list message):bool :=
match ml with
| nil  => true
| cons h tl => (andb (notocc_dec_msg x t h) (notocc_dec_mlist x  t tl ))
end.

(*******In a Bool list:  ilist Bool n************)

Fixpoint notocc_dec_blist (x:nat) (t:message)(ml : list Bool ):bool :=
match ml with
| nil => true
| cons h tl => (andb (notocc_dec_bol x t h) (notocc_dec_blist x t tl))
end.

(********In a mylist : mylist n********)

Fixpoint notocc_dec_mylist {m:nat}(x:nat)(t:message) (ml :  mylist m):bool :=
match ml with
| [] => true
| h :: ml1 => (andb (notocc_dec_os x t h) (notocc_dec_mylist x t ml1))
end.

(*******************************************************************************************************)
(***********Formula*************************************************************************************)
(****
Definition formula (u u' u'': message) (n n1 n2 n3 :nat){m} (l:mylist m) : Prop := (l [[ n ]]) /\ (clos_listm [u;u';u'']  = true)/\  ( onlyin_pkrsk_mylist n1  ( (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ++ (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l)) = true) /\  ( skn_in_dec_mylist n1 ((submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ++ (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l)) = true) /\ (notocclist_mylist [n2; n3]  ((submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ++ (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u' (pk n1) (r n3)) u'') l)) = true)  -> (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l).
**)

(********************ENCCPA*******************************************)
(********************************************************************)

Axiom ENCCPA: forall (u u' u'': message) (n n1 n2 n3 :nat){m} (l:mylist m), ( (var_free_mylist n l) = true) /\ (clos_listm [u; u'; u''] = true) /\  (notocc_skn_mylist n1  ((submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ++
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l)) = true)  -> (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l).

(********************ENCCCA1*****************************************)
(********************************************************************)

Axiom ENCCCA1 : forall (t u u' u'': message) (n n1 n2 n3 :nat){m} (l :mylist m), (var_free_msg n t = true) /\ (var_free_mylist n l = true)  /\ (notocc_dec_mlist n1 t  (subterm_list_mylist  l ) = true) -> (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l).

(*********************ENCCA2***************************************)
(******************************************************************)

Axiom ENCCCA2: forall (t1 t2 u u' u'': message) (n n1 n2 n3 m :nat) (l:mylist m),  (var_free_mylist n ([msg t1; msg t2] ++ l) = true) /\  ((notocc_dec_mlist n1 t1  (subterm_list_mylist  l ) = false) ->  (dec t1 (sk n1)) # (if_then_else_M  ((EQ_M t1  (Mvar 2))& (EQ_M (L u) (L u'))) t2 (dec t1 (sk n1)))) ->
 (submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n2)) u'') l) ~
(submsg_mylist n (if_then_else_M (EQ_M (L u) (L u')) (enc u (pk n1) (r n3)) u'') l).
(*****nonce and key generation ******)

Definition lnonce {n} := (L (N n)).
(**Definition lskey {n} := (L (sk n)).**)

(*******length regular********)

Axiom len_regular: forall (x1 x2 y1 y2 :message), (L x1) # (L y1) /\ (L x2) # (L y2) -> (L (pair x1 x2)) # (L (pair y1 y2)).

(******Idempotent L(L(x)) = L(x)**********)

Axiom idemp_L: forall x,  (L (L x)) # (L x).
Variable lskey : message.

Axiom lsk: forall n, lskey # (L (sk n)).

(**************real or random secrecy of n****)

Theorem RRS_n: forall (n n' n1 n2 n3 n4 n5 n6 :nat), [ msg (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3)))); msg (enc (pair (pi2 (dec (f [ (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n)] ~
 [ msg (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3)))); msg (enc (pair (pi2 (dec (f [ (enc (pair (sk  n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))) (N n)) (pk n1) (rs (N n4))); msg (N n')].

Proof. intros.

assert(H: (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) # (if_then_else_M (EQ_M (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))) (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]))).
pose proof (IFSAME_M).
rewrite IFSAME_M with (b:=  (EQ_M (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3)))))) (x:= (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])).
reflexivity.

assert (H1:  (pi2 (dec (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))) # (if_then_else_M  (EQ_M (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))])  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))) (N n5)  (pi2 (dec (f [ (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3))))]) (sk n2))))).

rewrite H at 1.

pose proof(Example11_M).

apply  Forall_ELM_EVAL_M1 with (n:=1) (x :=  (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))])) in H0. simpl in H0.
apply  Forall_ELM_EVAL_M1 with (n:=2) (x := (enc (pair (sk n1) ( N n5 )) (pk n2) (rs (N n3))) ) in H0. simpl in H0.
apply  Forall_ELM_EVAL_M1 with (n:=3) (x :=  (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))])) in H0. simpl in H0.

rewrite H0 .

assert(H3:  (pi2 (dec (if_then_else_M (Bvar 0)  (Mvar 1)  (Mvar 2)) (sk n2))) # (if_then_else_M (Bvar 0) (pi2 (dec (Mvar 1) (sk n2))) (pi2 (dec (Mvar 2) (sk n2))))).

rewrite <- IFSAME_M with (b:= (Bvar 0)) (x:=  (pi2 (dec (if_then_else_M (Bvar 0)  (Mvar 1)  (Mvar 2)) (sk n2)))).

rewrite IFEVAL_M .
simpl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
reflexivity.
apply Forall_ELM_EVAL_M with (n:=0) (x:= (EQ_M (f [enc (pair (sk n1) (N n5)) (pk n2) (rs (N n3))]) (enc (pair (pi2 (k (N n1))) (N n5)) (pi1 (k (N n2))) (rs (N n3))))) in H3.
simpl in H3.
apply  Forall_ELM_EVAL_M1 with (n:=1) (x :=  (enc (pair (pi2 (k (N n1))) (N n5)) (pi1 (k (N n2))) (rs (N n3)))) in H3. simpl in H3.
apply  Forall_ELM_EVAL_M1 with (n:=2) (x := (f [enc (pair (sk n1)  (N n5)) (pk n2) (rs (N n3))])) in H3. simpl in H3.

rewrite H3.
pose proof(dep_enc).
rewrite dep_enc with (n:=n2) (x:=  (pair (pi2 (k (N n1))) (N n5 ))) .
rewrite proj2 with (m1:= (pi2 (k (N n1)))) (m2 := (N n5)) .
reflexivity.
(*************definition************)

(*
Definition l := [msg (Mvar 1) ; msg (enc (if_then_else_M (EQ_M (f [Mvar 1]) (Mvar 1) ) (N n5) (pi2 (dec (f [Mvar 1]) (sk n2)))) (pk n2) (rs (N 3)) ) ; msg (N 0)].*)
(**************L<sk1 , n5> , L<sk6, n5> *********)

assert(H2: (L (pair (sk n1) (N n5))) # (L (pair (sk n6) (N n5)))).

apply len_regular.  split.
Focus 2.
reflexivity.

assert(H3: lskey # ( L (sk n1))).
rewrite lsk with (n:= n1).

reflexivity.

assert(H4: lskey # ( L (sk  n6))).
rewrite lsk with (n:= n6).

reflexivity.

rewrite <- H3.
rewrite <- H4.
reflexivity.
apply EQmsg in H2.
pose proof (IFTRUE_M).
pose proof (IFTRUE_M  (enc (pair (sk n1) (N n5)) (pk n2) (rs (N (n3)))) O).
rewrite <- H2 in H3.

pose proof (IFTRUE_M  (enc (pair (sk n6) (N n5)) (pk n2) (rs (N (n3)))) O).
rewrite <- H2 in H4.

simpl.

pose proof (ENCCCA2 (f [Mvar 1]) (N n5) (pair (sk n1) (N n5)) (pair (sk n6) (N n5)) O 1 n2 n3 n3 3 [msg (Mvar 1) ; msg (enc (if_then_else_M (EQ_M (f [(Mvar 1)]) (Mvar 1)) (N n5) (pi2(dec (f [(Mvar 1)]) (sk n2)))) (r n3) (pk n2) ); msg (N n)]).
simpl in H5.
Admitted.

github-repos/coq/ajayeeralla-compSoundProofsWOracleMoves/compSoundProofsWOracleMoves-8480855887a9092d16dc183ce6ed19315a3ffa96/CPA_CCA (Ajay’s MacBook Pro's conflicted copy 2016-08-23).v


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A1prime A2prime B1 B2 A1 I B3 A3 : Universe, ((wd_ B1 B2 /\ (wd_ A1prime A2prime /\ (wd_ A2prime B1 /\ (wd_ A1prime B1 /\ (wd_ B1 A1 /\ (wd_ B1 I /\ (wd_ B1 B3 /\ (wd_ A3 I /\ (wd_ B3 I /\ (wd_ A1 I /\ (wd_ A1 A1prime /\ (wd_ A3 B3 /\ (col_ A1prime A2prime A1 /\ (col_ I A1prime A2prime /\ (col_ I B1 B2 /\ (col_ A1prime A2prime A3 /\ (col_ B1 A1 I /\ col_ B3 B1 I))))))))))))))))) -> col_ A1 B1 A3)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* --------------------------------------------------------------------
 * (c) Copyright 2011--2012 Microsoft Corporation and Inria.
 * (c) Copyright 2012--2014 Inria.
 * (c) Copyright 2012--2014 IMDEA Software Institute.
 * -------------------------------------------------------------------- *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import ssreflect ssrnat ssrbool eqtype seq.
From mathcomp Require Import fintype choice tuple perm zmodp ssrfun.
From mathcomp Require Import bigop ssralg ssrint ssrnum generic_quotient.

Require Import xseq xmatrix polyall polydec polyfrac.
Require Import fraction fracfield SsrMultinomials.freeg.
Require Import ec ecpoly eceval ecorder ecdiv.

(* -------------------------------------------------------------------- *)
Import GRing.Theory.
Import Num.Theory.
Import fraction.FracField.
Import fracfield.FracField.
Import FracInterp.
Import PreClosedField.

(* -------------------------------------------------------------------- *)
Local Open Scope ring_scope.

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

Local Notation simpm := Monoid.simpm.

(* -------------------------------------------------------------------- *)
Reserved Notation "p \PFo f" (at level 50).
Reserved Notation "f \Fo g"  (at level 50).

Section FracECPoly.
  Variable K : ecuDecFieldType.
  Variable E : ecuType K.

  Notation Xpoly   := (@Xpoly K E).
  Notation ecpoly  := (@ecpoly K E).
  Notation oncurve := (@oncurve K E).

  Notation "f .[ x , y ]" := (eceval f x y).
  Notation "p %:E" := (ecX E p).

  Hypothesis closedK : GRing.ClosedField.axiom K.

  Local Notation clK := (ClosedFieldType K closedK).

  Local Notation PEF := (@tofrac _ \o ((ecX _) \o polyC)).
  Local Notation "x %:PEF" := (PEF x) (at level 2).

  Delimit Scope G with G.

  Local Notation "\- x"   := (@ECGroup.neg _ x)     : G.
  Local Notation "x \+ y" := (@ECGroup.add _ E x y) : G.
  Local Notation "x \- y" := (x \+ (\- y))%G        : G.

  Local Notation neq0 := (mulf_neq0, invr_eq0, ecX_eq0, tofrac_eq0, conjp_eq0).

  Local Hint Extern 0 (is_true (ec.Xpoly _ != 0)) => exact: XpolyN0.

  Definition proportional (p q : ecpoly) :=
    [&& (p.1 %= q.1), (p.2 %= q.2) &
      (lead_coef p.1 * lead_coef q.2 == lead_coef p.2 * lead_coef q.1)].

  Lemma pptnle0 p: (proportional p 0) = (p == 0).
  Proof.
    rewrite /proportional /= lead_coef0 !mulr0 eqxx andbT.
    by case: p => [[p1 p2]] /=; apply/esym; rewrite !eqp0 eqE /=.
  Qed.

  Lemma pptnlC: commutative proportional.
  Proof.
    move=> p q; rewrite /proportional; congr ([&& _, _ & _]);
      last 1 [idtac] || by rewrite /eqp andbC.
    by rewrite eq_sym mulrC [X in _ = (_ == X)]mulrC.
  Qed.

  Lemma pptnl0e p: (proportional 0 p) = (p == 0).
  Proof. by rewrite pptnlC pptnle0. Qed.

  Lemma eqpfP (p q : {poly K}):
    p %= q -> (lead_coef q) *: p = (lead_coef p) *: q.
  Proof.
    have [->|nz_q] := eqVneq q 0.
      by rewrite eqp0 => /eqP ->.
    move/eqpfP=> ->; rewrite lead_coefZ scalerA.
    by rewrite mulrCA -mulrA [_ ^-1 * _]mulrC.
  Qed.

  Lemma pptnlrP (p q : ecpoly):
    reflect (exists2 c, (c.1 != 0) && (c.2 != 0)
                      & ((c.1%:P)%:E) * p = ((c.2%:P)%:E) * q)
            (proportional p q).
  Proof.
    case: p q => [[p1 p2]] [[q1 q2]] /=; apply: (iffP idP).
    + case/and3P=> /=; have [->|nz_q1] := (eqVneq q1 0).
        rewrite eqp0 => /eqP->; have [->|nz_q2] := eqVneq q2 0.
          by rewrite eqp0 => /eqP-> _; exists (1, 1) => //=; rewrite oner_eq0.
        case/eqpP=> c nz_c pp_p2_q2 _; exists c => //.
        by rewrite -!ecXM !mul_polyC pp_p2_q2.
      have [->|nz_p1] := (eqVneq p1 0); first by rewrite eqp_sym eqp0 (negbTE nz_q1).
      case/eqpP=> c /andP [nz_c1 nz_c2] pp_p1_q1; have [->|nz_q2] := eqVneq q2 0.
        rewrite eqp0 => /eqP-> _; exists c; first by rewrite nz_c1 nz_c2.
        rewrite ![_%:E * _]mulrC !ecY_ecX_mul ![_*_%:P]mulrC.
        by rewrite !mul_polyC pp_p1_q1.
      have [->|nz_p2] := (eqVneq p2 0); first by rewrite eqp_sym eqp0 (negbTE nz_q2).
      case/eqpP=> c' /andP [nz_c'1 nz_c'2] pp_p2_q2 /eqP eq_lc.
      exists (c.1, c.2) => //=; first by apply/andP; split.
      rewrite !mulE /dotp /= !simpm; apply/eqP; do 2! rewrite eqE /=.
      have/(congr1 (( *%R ) (c'.1 *: p2))) := pp_p1_q1; rewrite {1}pp_p2_q2.
      move/(congr1 lead_coef); rewrite !lead_coefM !lead_coefZ.
      rewrite [X in X = _]mulf_cross [X in _ = X]mulf_cross.
      rewrite -eq_lc [lead_coef p1 * _]mulrC => /mulIf.
      rewrite mulf_neq0 ?lead_coef_eq0 // => /(_ (erefl true)) => eq_c.
      rewrite !mul_polyC pp_p1_q1 eqxx /=; apply/eqP.
      apply/(scalerI (a := c'.1)) => //; rewrite scalerA [_*c.1]mulrC.
      by rewrite -scalerA pp_p2_q2 !scalerA [c.1*_]mulrC eq_c.
    + case=> [[c1 c2]] /= /andP [nz_c1 nz_c2]; rewrite !mulE /dotp /= !simpm.
      case=> eq1 eq2; apply/and3P; split=> /=.
      * apply/eqpP; exists (c1, c2); first by rewrite nz_c1 nz_c2.
        by rewrite -!mul_polyC /= eq1.
      * apply/eqpP; exists (c1, c2); first by rewrite nz_c1 nz_c2.
        by rewrite -!mul_polyC /= eq2.
      apply/eqP; apply/(mulfI (x := c1 * c2)); first by rewrite mulf_neq0.
      rewrite [X in X = _]mulf_cross [X in _ = X]mulf_cross.
      rewrite -2!lead_coefZ -!mul_polyC eq1 -eq2.
      by rewrite !mul_polyC !lead_coefZ [X in X = _]mulrC.
   Qed.

   Lemma pptnlP (p q : ecpoly):
     reflect (exists2 c, c != 0 & p = ((c%:P)%:E) * q)
             (proportional p q).
   Proof.
     apply: (iffP idP).
     + move/pptnlrP=> [[c1 c2] /= /andP [nz_c1 nz_c2]] eq; exists (c2 / c1).
       * by rewrite mulf_neq0 // invr_eq0.
       * apply/(@mulfI _ (c1%:P)%:E); first by rewrite ecX_eq0 polyC_eq0.
         rewrite mulrCA mulrA -ecXM -polyC_mul [_ * c1]mulrAC -mulrA.
         by rewrite divff // mulr1 eq.
     + case=> c nz_c ->; apply/and3P; rewrite mulE /dotp /= !simpm; split.
       * apply/eqpP; exists (1, c) => /=; first by rewrite oner_eq0.
         by rewrite scale1r mul_polyC.
       * apply/eqpP; exists (1, c) => /=; first by rewrite oner_eq0.
         by rewrite scale1r mul_polyC.
       * by rewrite !lead_coefM mulrAC.
    Qed.

   Definition constant_ratio (h : {ratio ecpoly}) :=
     (\n_h == 0) || (proportional \n_h \d_h).

   Definition constant_fraction (h : {fraction ecpoly}) :=
     (lift_fun1 {fraction ecpoly} constant_ratio h).

   Lemma pi_constant_fraction :
     {mono \pi_({fraction ecpoly})%qT : f /
       constant_ratio f >-> constant_fraction f}.
   Proof.
     move=> f; unlock constant_fraction; set g := (repr _).
     have: (g = f %[mod {fraction ecpoly}])%qT.
     + by rewrite reprK.
     case: f g => [[nf df] /= nz_df] [[ng dg] /= nz_dg] /=.
     move/eqmodP => /=; rewrite FracField.equivfE /= => eqE.
     rewrite /constant_ratio /= .

     move: eqE; case: (ng =P 0) => [|/eqP nz_ng] /=.
     + move=> -> /=; rewrite mul0r eq_sym mulf_eq0.
       by rewrite (negbTE nz_dg) /= => ->.
     case: (nf =P 0) => [->|/eqP nz_nf].
     + by rewrite mulr0 mulf_eq0 (negbTE nz_ng) (negbTE nz_df).

     move=> eqE; apply/pptnlP/pptnlP.

     case=> c1 nz_c1 eq.
     exists c1; move=> //.
     move: eqE ; rewrite eq.
     rewrite mulrAC mulrC -subr_eq0 -mulrBr.
     move/eqP => H.
     have hypothesis : (c1%:P)%:E * df - nf == 0.
     by move/idomainAxiom : H; rewrite (negbTE nz_dg) //.
     symmetry; apply /eqP; by rewrite -subr_eq0.

     case=> c1 nz_c1 eq.
     exists c1; move=> //.
     move: eqE; rewrite eq mulrA -subr_eq0 -mulrBl.
     move/eqP => H.
     have hypothesis : ng - dg * (c1%:P)%:E == 0.
     by move/idomainAxiom : H; rewrite (negbTE nz_df) Bool.orb_false_r.
     by apply /eqP; rewrite -subr_eq0 mulrC.
   Qed.

   Local Open Scope quotient_scope.

   Canonical pi_constant_fraction_morph := PiMono1 pi_constant_fraction.

   Lemma constant_fractionP (f: {fraction ecpoly}):
     reflect
       (exists c, f = ((c%:P)%:E)%:F)
       (constant_fraction f).
   Proof.
     apply: (iffP idP); elim/quotW: f => f;
       rewrite !piE; case: f => [[n d] /= nz_d];
       rewrite /constant_ratio /=.
     + case/orP => [/eqP->|].
       * exists 0; rewrite !piE; apply/eqmodP; rewrite /= equivfE /=.
         by rewrite !numden_Ratio ?oner_eq0 // !simpm.
       move/pptnlP => [c nz_c En]; exists c.
       rewrite !piE; apply/eqmodP=> /=; rewrite equivfE /=.
       by rewrite !numden_Ratio ?oner_eq0 // mulr1 mulrC En.
     + case=> c; rewrite !piE => /eqmodP /=; rewrite equivfE /=.
       rewrite !numden_Ratio ?oner_eq0 // mulr1 => /eqP ->.
       rewrite mulf_eq0 (negbTE nz_d) /=; case: (c =P 0).
       * by move=> ->; rewrite eqxx.
       move/eqP=> nz_c; apply/orP; right; apply/pptnlP.
       by exists c=> //; rewrite mulrC.
   Qed.

  (* ================================================================== *)
  Lemma constant_fraction_order0 :
  forall (f : {fraction ecpoly}) (P : point K),
  order f P != 0 -> ~~ (constant_fraction f).
  Proof.
  move=> f P ordP_nz.
  apply/constant_fractionP; case=> c H.
  move: (orderC E c P); rewrite -H; move=> h.
  move:ordP_nz; by rewrite h.
  Qed.

  Lemma constant_fraction0: constant_fraction 0.
  Proof. by apply/constant_fractionP; exists 0. Qed.

  Lemma constant_fractionC c: constant_fraction c%:PEF.
  Proof. by apply/constant_fractionP; exists c. Qed.

  Lemma fctt_shift (f : {fraction ecpoly}) (c : K):
    (constant_fraction (f - c%:PEF)) = (constant_fraction f).
  Proof.
    apply/constant_fractionP/constant_fractionP.
    + case=> fc /eqP; rewrite subr_eq => /eqP ->.
      by exists (fc + c); rewrite !(rmorphD, ecXD).
    + case=> fc ->; exists (fc - c).
      by rewrite !(rmorphB, ecXB).
  Qed.

  Lemma Nfctt_neq0 (f : {fraction ecpoly}):
    ~~ (constant_fraction f) -> f != 0.
  Proof.
    move=> Nctt; apply/eqP=> z_f; move: Nctt.
    by rewrite z_f constant_fraction0.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma reduced_polyratio (p : {polyratio K}):
    reducep p = p.
  Proof.
    apply: polyratio_axiom_uniq.
    + exact: reducep_axiom.
    + by case: p.
    + exact: reducep_eqmod.
  Qed.

  (* -------------------------------------------------------------------- *)
  Require Import eceval.

  Reserved Notation "e .[! x , y ]" (at level 2, format "e .[! x ,  y ]").

  Implicit Types p q : {poly K}.
  Implicit Types f : {fraction {poly K}}.
  Implicit Types e : {fraction ecpoly}.

  Definition comp_poly_fec e p := (map_poly PEF p).[e].

  Lemma comp_poly_fec_is_additive e: additive (comp_poly_fec e).
  Proof.
    by move=> p q /=; rewrite /comp_poly_fec rmorphB /= !hornerE.
  Qed.

  Canonical comp_poly_fec_additive e :=
    Additive (comp_poly_fec_is_additive e).

  Lemma comp_poly_fec_is_multiplicative e: multiplicative (comp_poly_fec e).
  Proof.
    split; last first.
      by rewrite /comp_poly_fec rmorph1 hornerC.
    by move=> p q /=; rewrite /comp_poly_fec rmorphM /= !hornerE.
  Qed.

  Canonical comp_poly_fec_multiplicative e :=
    AddRMorphism (comp_poly_fec_is_multiplicative e).

  Notation "p \PFo e" := (comp_poly_fec e p).

  Lemma comp_polyX_fec e: ('X \PFo e) = e.
  Proof. by rewrite /comp_poly_fec map_polyX hornerX. Qed.

  Lemma comp_polyC_fec c e: (c%:P \PFo e) = c%:PEF.
  Proof. by rewrite /comp_poly_fec map_polyC /= hornerC. Qed.

  Lemma comp_polyD_fec p q e:
  (p + q) \PFo e = (p \PFo e) + (q \PFo e).
  Proof. by rewrite /comp_poly_fec rmorphD /= hornerD. Qed.

  Lemma comp_polyM_fec p q e:
    (p * q) \PFo e = (p \PFo e) * (q \PFo e).
  Proof. by rewrite /comp_poly_fec rmorphM /= hornerM. Qed.

  Notation "e .[! x , y ]" := (eval e (|x, y|)).

  Local Notation "x \+ y" := (FracInterp.add x y).
  Local Notation "x \* y" := (FracInterp.mul x y) (at level 30).

  Lemma eval_ge0_order (f : {fraction ecpoly}) (p : point K):
    (isfinite (eval f p)) = (0 <= order f p).
  Proof.
    apply/idP/eval_ge0_orderP.
    + by case: (eval f p) => [g|//] _; exists g.
    + by case=> g ->.
  Qed.

  Lemma eval_comp_fec p e g:
    oncurve g -> (size p > 1)%N ->
      (eval (p \PFo e) g) =
        match eval e g with
        | z%:PP => (p.[z])%:PP
        | [inf] => [inf]
        end.
  Proof.
    move=> oncve nc_p; elim/poly_ind: p nc_p => [|p c IH].
      by rewrite size_poly0.
    rewrite size_MXaddC; case: (p =P 0) => [->|/eqP nz_p].
      by rewrite /=; case: (_ == 0); rewrite ?size_poly0.
    move=> _; rewrite !(rmorphD, rmorphM) /= comp_polyX_fec comp_polyC_fec.
    rewrite evalDr evalC //; case: (ltnP 1 (size p)); last first.
      move=> lt_szp_1; rewrite [p]size1_polyC //; set k := p`_0.
      rewrite comp_polyC_fec evalM_finL ?orderC // evalC //.
      case: (eval e _) => [z|]; first by rewrite !hornerE.
      rewrite /= -(inj_eq (@polyC_inj _)) -size1_polyC //.
      by rewrite (negbTE nz_p).
    move/IH=> {IH} IH; rewrite evalM; last first.
      rewrite -sgzM sgz_ge0; case: (ltrP (order e g) 0).
      + move=> lt_oe_0; rewrite nmulr_lge0 // ltrW //.
        rewrite eval_lt0_order IH; move: lt_oe_0.
        by rewrite eval_lt0_order => /eqP ->.
      + move=> ge_oe_0; rewrite mulr_ge0 //.
        rewrite -eval_ge0_order IH.
        by move/eval_ge0_orderP: ge_oe_0 => [z ->].
    rewrite IH; case: (eval e _) => [z|] //.
    by rewrite !hornerE.
  Qed.

  Definition fzeros (e : {fraction ecpoly}): seq (point K) :=
    dom (fgpos (ecdiv e)).

  Lemma fzerosP e: e != 0 ->
    forall (g : point K), oncurve g -> (g \in fzeros e) = (eval e g == 0%:PP).
  Proof.
    move=> nz_e g oncve; rewrite /fzeros mem_dom inE /= coeff_fgposE.
    by rewrite eqr_maxl -ltrNge ecdiv_coeffE eval_gt0_order.
  Qed.

  Lemma comp_poly_fec_eq0 p e:
    p != 0 -> p \PFo e == 0 -> constant_fraction e.
  Proof.
    move=> nz_p z_pe; case: (leqP (size p) 1).
      move=> le_szp_1; move: z_pe; rewrite [p]size1_polyC //.
      rewrite comp_polyC_fec tofrac_eq0 ecX_eq0.
      by rewrite -size1_polyC // (negbTE nz_p).
    move=> lt_1_szp; pose eg g := gproject (eval e g).
    have: forall g, eval e g = (eg g)%:PP.
      move=> g; case oncve_g: (oncurve g); last first.
        by rewrite /eg !eval_outcve ?oncve_g //.
      have/eval_comp_fec := lt_1_szp => /(_ e g oncve_g).
      by rewrite /eg (eqP z_pe) eval0; case: (eval e g).
    move=> fin_eg; have: forall g, oncurve g -> p.[eg g] == 0.
      move=> g oncve_g; have/eval_comp_fec := lt_1_szp => /(_ e g oncve_g).
      by rewrite fin_eg /= (eqP z_pe) eval0 => [[<-]].
    move=> eg_root_p; case ctt_e: (constant_fraction e) => //.
    pose pj g := match g with (|x, y|) => Some (x, y) | _ => None end.
    pose R g := pmap (pj K) (fzeros (e - g%:PEF)).
    pose G := flatten [seq R g | g <- roots p].
    pose q := (\prod_(g <- G) ('X - g.1%:P)).
    pose a := (root1 Xpoly, 0 : K).

    have nz_eBC c: e - c%:PEF != 0.
      by apply: Nfctt_neq0; rewrite fctt_shift ctt_e.

    have: forall x y, oncurve (|x, y|) -> (x, y) \in G.
      move=> x y oncve_xy; rewrite /G; apply/flattenP.
      exists (R (eg (|x, y|))).
      + apply/mapP; exists (eg (|x, y|)) => //.
        by rewrite rootsP // mem_root; apply: eg_root_p.
      + rewrite /R mem_pmap; apply/mapP; exists (|x, y|) => //.
        rewrite fzerosP ?nz_eBC //.
        by rewrite evalDl ?fin_eg // -rmorphN evalC //= subrr.

    have oncve_a: oncurve (|a.1, a.2|).
      rewrite /a /= -horner_Xpoly eq_sym expr0n /=.
      rewrite  -rootE root1_root //.
      by rewrite (@hasroot_size_neq1 clK) size_Xpoly.
    move/(_ a.1 a.2 oncve_a) => a_in_G.

    set z := root1 (q + 1); have z_root_qS: root (q + 1) z.
      have: (size q > 1)%N.
        rewrite /q size_prod_XsubC ltnS lt0n size_eq0.
        by apply/eqP => G_eq0; rewrite G_eq0 in_nil in a_in_G.
      move=> lt_1_szq; apply: root1_root.
      rewrite (@hasroot_size_neq1 clK) size_addl.
      + by rewrite eq_sym neq_ltn lt_1_szq.
      + by rewrite size_poly1.

    pose b := (z, sqrt Xpoly.[z]).

    have oncve_b: oncurve (|b.1, b.2|).
    + by rewrite {}/b /= -horner_Xpoly (@sqr_sqrt clK).

    have/(_ (|b.1, b.2|) oncve_b) := eg_root_p; set g := eg _.
    move=> root_p_g; have: b \in R g.
      rewrite /R mem_pmap; apply/mapP.
      exists (|b.1, b.2|) => //; rewrite /g.
      rewrite fzerosP ?nz_eBC // evalDl ?fin_eg //.
      by rewrite -!rmorphN evalC //= subrr.

    move=> b_in_Rg; have: b \in G.
      rewrite /G; apply/mem_flattenP; exists (R g) => //.
      + by apply/mapP; exists g => //; rewrite rootsP.

    move=> b_in_G; have: root q z.
      rewrite rootE /q horner_prod.
      rewrite (eq_big_perm _ (perm_to_rem b_in_G)) /=.
      by rewrite big_cons /b /= !hornerE subrr mul0r.

    move=> z_root_q; move: z_root_qS; rewrite rootE.
    by rewrite !hornerE (rootP z_root_q) add0r oner_eq0.
  Qed.

  Definition comp_frac_fec f e: {fraction ecpoly} :=
    gproject (map_polyfrac PEF f).[!e].

  Notation "f \Fo e"  := (comp_frac_fec f e).

  Lemma comp_fracC_fec e c: (c%:P)%:F \Fo e = c%:PEF.
  Proof.
    rewrite /comp_frac_fec /gproject map_polyfracF map_polyC /=.
    by rewrite finterp_poly hornerC.
  Qed.

  Lemma comp_frac_fecE n d e: ~~ (constant_fraction e)
    -> (n // d) \Fo e = (n \PFo e) / (d \PFo e).
  Proof.
    move=> Nccte; have [->|nz_n] := eqVneq n 0.
      by rewrite comp_polyC_fec !mul0r comp_fracC_fec.
    have [->|nz_d] := eqVneq d 0.
      by rewrite comp_polyC_fec !invr0 !mulr0 comp_fracC_fec.
    rewrite /comp_frac_fec map_polyfracE /= finterp_nzden //=.
    by apply/negP => /comp_poly_fec_eq0 -/(_ nz_d); rewrite (negbTE Nccte).
  Qed.

  Lemma comp_fracD_fec f1 f2 e:
  ~~ (constant_fraction e) ->
  (f1 + f2) \Fo e = (f1 \Fo e) + (f2 \Fo e).
  Proof.
    elim/fracW: f1 => n1 d1 nz_d1;
    elim/fracW: f2 => n2 d2 nz_d2.
    move=> NCFe.
    rewrite !comp_frac_fecE // addf_div ?tofrac_eq0 //.
    rewrite -!tofracM -tofracD comp_frac_fecE // !addf_div.
    + rewrite comp_polyM_fec; congr (_ / _).
    by rewrite comp_polyD_fec !comp_polyM_fec.
    + case Hd1: (d1 \PFo e == 0).
    move: (@comp_poly_fec_eq0 d1 e nz_d1).
    by rewrite (negbTE NCFe); apply; rewrite (eqP Hd1).
    rewrite //.
    + case Hd2: (d2 \PFo e == 0).
    move: (@comp_poly_fec_eq0 d2 e nz_d2).
    by rewrite (negbTE NCFe); apply; rewrite (eqP Hd2).
    rewrite //.
  Qed.

  Lemma comp_fracM_fec f1 f2 e: ~~(constant_fraction e) ->
    (f1 * f2) \Fo e = (f1 \Fo e) * (f2 \Fo e).
  Proof.
    elim/fracW: f1 => n1 d1 nz_d1;
    elim/fracW: f2 => n2 d2 nz_d2;
      rewrite mulf_div -!tofracM => Nctt_e.
    by rewrite !comp_frac_fecE // !comp_polyM_fec mulfE.
  Qed.

  Lemma comp_frac_prod_fec (I : Type) (r : seq I) (P : pred I) F (e : {fraction ecpoly}):
       ~~ constant_fraction e
    -> (\prod_(i <- r | P i) (F i)) \Fo e = \prod_(i <- r | P i) ((F i) \Fo e).
  Proof.
    move=> Ncct_e; elim: r => [|i r IH].
      by rewrite !big_nil comp_fracC_fec.
    by rewrite !big_cons; case: (P i); rewrite ?comp_fracM_fec // IH.
  Qed.

  Lemma comp_fracF_fec (p : {poly K}) (e : {fraction ecpoly}):
    ~~ constant_fraction e -> p%:F \Fo e = p \PFo e.
  Proof.
    move=> Ncct_e; rewrite -[_%:F]divr1 -[1]tofrac1 comp_frac_fecE //.
    by rewrite comp_polyC_fec divr1.
  Qed.

  Lemma comp_fracV_fec f e: ~~(constant_fraction e) ->
    (f^-1) \Fo e = (f \Fo e)^-1.
  Proof.
    move=> Nctt_e; elim/fracW: f => n d nz_d.
    by rewrite invfE !comp_frac_fecE // invfE.
  Qed.

  (*bad name*)
  Lemma comp_fracXn_fec e f n: ~~ (constant_fraction e) ->
    (f \Fo e) ^+ n = (f ^+ n) \Fo e.
  Proof.
    move=> Nctt_e; elim: n => [|n IH].
      by rewrite !expr0 comp_fracC_fec.
    by rewrite !exprS comp_fracM_fec // IH.
  Qed.

  (*bad name*)
  Lemma comp_fracX_exp f e (z : int): ~~ (constant_fraction e) ->
    (f \Fo e) ^ z = (f ^ z) \Fo e.
  Proof.
    move=> Nctt_e; case: z => n.
    + by rewrite -!exprnP comp_fracXn_fec.
    + by rewrite !NegzE -!exprnN comp_fracV_fec // comp_fracXn_fec.
  Qed.

  (*bad name*)
  Lemma comp_fracX_fec f e (n : nat):
     ~~ constant_fraction e ->
     comp_frac_fec (f ^+ n) e = (comp_frac_fec f e) ^+ n.
  Proof.
    move=> Nctt_e; elim: n.
    + rewrite !expr0 comp_fracC_fec //=.
    + move=> n IH.
    by rewrite !exprS comp_fracM_fec // IH.
  Qed.

  (*XXX*)
  Lemma ecdiv_eq0_cct (f : {fraction ecpoly}):
    ecdiv f = 0 -> constant_fraction f.
  Proof.
    have [->|nz_f] := (eqVneq f 0).
      by rewrite constant_fraction0.
    elim/fracW: f nz_f => n d nz_d.
    rewrite mulf_eq0 tofrac_eq0 => /norP [nz_n _].
    have ->: n // d = (n * conjp d) // (normp d)%:E.
      rewrite -[_%:E]conjp_normp !tofracM -mulfE divff ?mulr1 //.
      by rewrite tofrac_eq0 conjp_eq0.
    set n1 := n * _; set d1 := (normp _).
    have nz_n1: n1 != 0 by rewrite mulf_neq0 ?conjp_eq0.
    have nz_d1: d1 != 0 by rewrite norm_eq0.
    move: {n d nz_n nz_d} n1 d1 nz_n1 nz_d1 => n d nz_n nz_d.
    move=> eq0_div; have eq0_divcj: ecdiv ((conjp n) // d%:E) = 0.
      apply/eqP/freeg_eqP=> p; rewrite !ecdiv_coeffE coeff0.
      move/eqP/freeg_eqP: eq0_div => /(_ (\- p)%G).
      rewrite !ecdiv_coeffE coeff0 -[_ // _]conjK.
      by rewrite order_conj conjE conjp_ecX.
     have ord_f: forall (p : point _), 0 <= order (n // d%:E) p.
     by move=> p; rewrite -ecdiv_coeffE eq0_div coeff0.
    have ord_cf: forall (p : point _), 0 <= order (conjp n // d%:E) p.
      by move=> p; rewrite -ecdiv_coeffE eq0_divcj coeff0.
    have order_n2: forall (p : point _), order (n.2 %:E // d%:E) p >= 0.
      pose f := n // d%:E; move=> p; case oncve: (oncurve p); last first.
        by rewrite order_outcve // oncve.
      move/(congr1 (fun e => eval e p)): (erefl (f + conj f)).
      rewrite {1 2}/f; rewrite {1}conjE conjp_ecX /ecX -mulrDl.
      rewrite -tofracD -[n]ecpolyE /conjp addE /= subrr -mulr2n.
      rewrite -mulr_natl -!/(ecX _ _) ecXM tofracM -mulrA.
      rewrite /GRing.one /= -polyC_muln evalM_finL ?orderC //.
      rewrite evalC // evalDl; last first.
        by case/(eval_ge0_orderP): (ord_f p)=> c ->.
      rewrite /f conjE conjp_ecX;
        case/(eval_ge0_orderP): (ord_f  p)=> c1 ->;
        case/(eval_ge0_orderP): (ord_cf p)=> c2 ->.
      rewrite -eval_ge0_order; case: (eval (_ // _)) => //=.
      by rewrite (negbTE (ecu_chi2 _)).
    have order_n1: forall (p : point _), 0 <= order ([ecp n.1 *Y + 0] // d%:E) p.
      pose f := n // d%:E; move=> p; case oncve: (oncurve p); last first.
        by rewrite order_outcve // oncve.
      move: (erefl f); move/(congr1 (+%R^~ (- (n.2%:E // d%:E)))).
      rewrite {1}/f -{1}mulNr -mulrDl -{1}[n]ecpolyE -tofracB.
      rewrite -ecXN addE /= subrr addr0 => /esym.
      move/(congr1 (fun e => eval e p)); rewrite evalDl; last first.
        by case/(eval_ge0_orderP): (ord_f p)=> c1 ->.
      rewrite evalN; case/(eval_ge0_orderP): (order_n2 p)=> c ->.
      case/(eval_ge0_orderP): (ord_f p)=> cf -> /=.
      move: (cf - c) => {cf c} c /esym eval_n1d.
      by rewrite -eval_ge0_order eval_n1d.
    have: forall p : point K, 0 <= order ((n.1)%:E // d%:E) p.
      move=> p; have [->|nz_n1] := (eqVneq n.1 0).
        by rewrite mul0r order0.
      case oncve: (oncurve p); last by rewrite order_outcve ?oncve.
      move/eval_ge0_orderP: (order_n1 p) => [c].
      move/(congr1 (fun x => x \* x)); rewrite -evalM; last first.
        by rewrite -sgzM -expr2 sgzX sqr_ge0.
      rewrite mulf_cross -!expr2 exprVn -tofracX ecY_sqr /=.
      move: (c * c) => {c} c /eval_fin_order_ge0.
      rewrite ecXM tofracM mulrAC ecXX tofracX -divf_exp.
      rewrite [X in 0 <= X -> _]order_mul ?(neq0, XpolyN0) // order_exp.
      case: p oncve => [|x y] oncve /=.
        by rewrite orderF_inf subr_ge0; case: (order _ _).
      move: oncve; have [->|nz_y] := (eqVneq y 0); last first.
        move=> oncve; have /eqP->: order (Xpoly%:E)%:F (|x, y|) == 0.
          rewrite -order_poly_cmp0 ?ecX_eq0 // ecX_eceval.
          apply/negP=> root_Xc; have := oncve; rewrite oncurve_root.
          rewrite rootE !hornerE (eqP root_Xc) subr0 -expr2.
          by rewrite sqrf_eq0 (negbTE nz_y).
        by rewrite addr0 pmulrn_lge0.
      rewrite -Xpoly_oncurve => oncve; move: (order_Xpoly_le2 E (|x, 0|)) => h.
      rewrite addrC -[X in _ + X]opprK subr_ge0 => h'.
      move: {h h'} (ler_trans h' h).
      rewrite -mulNrn -natz ler_muln2r /= ler_eqVlt; case/orP.
      + rewrite eqr_oppLR => /eqP orderE; move: (even_orderS n.1 d oncve).
        by rewrite orderE abszN absz1.
      + by case: (order _ _).
    move=> {order_n1} order_n1.

    (*to use and not ord_f*)
    have ord_F: forall (p : point _), 0 = order (n // d%:E) p.
     by move=> p; rewrite -ecdiv_coeffE eq0_div coeff0.
    have ord_cF: forall (p : point _), 0 = order (conjp n // d%:E) p.
      by move=> p; rewrite -ecdiv_coeffE eq0_divcj coeff0.
     (**)

    pose Y := ([ecp 1 *Y + 0]%:F : {fraction {ecpoly E}}).
    have fE: n // d%:E = ((n.1%:E) // d%:E) * Y + ((n.2%:E) // d%:E).
    + rewrite /Y mulrAC -tofracM mulE /dotp /= !simpm.
      by rewrite -mulrDl -tofracD addE /= !simpm ecpolyE.

    have f_ecpoly: exists f : ecpoly, f%:F = n // d%:E.
    + rewrite fE;  have h q:
           (forall p : point K, 0 <= order (q%:E // d%:E) p)
        -> exists q', q%:E // d%:E= q'%:E%:F.
      * move=> order_q; have [->|q_eq0] := (eqVneq q 0).
          by exists 0; rewrite mul0r.
        case: (@finterp_all_finite clK q d); last move=> r1 ->.
          by rewrite mulf_neq0 // ?invr_eq0 tofrac_eq0.
        move=> x; set y := sqrt (Xpoly.[x]).
        rewrite -(eval_fracecX_fin (E := E) (y := y)); first last.
        * by apply: order_q.
        * by rewrite /= /y horner_Xpoly (@sqr_sqrt clK).
        * by rewrite eval_ge0_order.
        exists r1; rewrite ecXM tofracM -mulrA divff ?mulr1 //.
        by rewrite tofrac_eq0 ecX_eq0.
      case: (h n.1) => // q1 ->; case: (h n.2) => // q2 ->.
      exists [ecp q1 *Y + q2].
      rewrite -tofracM -tofracD mulE /dotp /= !simpm.
      by rewrite addE /= !simpm.

      case: f_ecpoly => f f_ecpoly.

      have order_eq0 : forall (p : point _), order f%:F p = 0.
      move=> p; by rewrite -ecdiv_coeffE f_ecpoly eq0_div coeff0.
      have [c f_constant]: exists c : K, f = (c%:P)%:E.
      + have [->|nz_f] := eqVneq f 0; first by exists 0.
        case: (all_order_eq0P closedK nz_f); case.
          by move=> x y; rewrite order_eq0.
        by move=> x nz_x -> _; exists x.
      apply/constant_fractionP; exists c.
      by rewrite -f_ecpoly -f_constant.
  Qed.

  Lemma eq_ecdiv_proportional_func (f g : {fraction ecpoly}):
       f != 0
    -> g != 0
    -> ecdiv f = ecdiv g
    -> exists2 a : K, a != 0 & f = g * (a%:PEF).
  Proof.
    move=> nz_f nz_g eq; set r := f / g; have: ecdiv r = 0.
      by rewrite ecdivM ?(mulf_neq0, invr_eq0) // ecdivV eq subrr.
    move/ecdiv_eq0_cct/constant_fractionP; case=> c hc; exists c.
    + apply/negP=> /eqP c_eq0; move/eqP: hc.
      by rewrite /r c_eq0 mulf_eq0 invr_eq0 (negbTE nz_f) (negbTE nz_g).
    + by rewrite /= -hc /r mulrCA divff // mulr1.
  Qed.

  Lemma ecdiv_eq0_constant_fraction (f : {fraction ecpoly}) :
    (ecdiv f == 0) = (constant_fraction f).
  Proof.
    apply/eqP/idP.
    + elim/fracW: f => n d nz_d; have [->|nz_n] := eqVneq n 0.
        by rewrite mul0r constant_fraction0.
      by move=> h; rewrite ecdiv_eq0_cct.
    + by case/constant_fractionP => c ->; rewrite ecdivC.
  Qed.

  Lemma Nctt_surjective (f : {fraction ecpoly}) x:
    ~~ constant_fraction f -> exists2 P, oncurve P & eval f P = x.
  Proof.
    move=> Nctt_f; have := Nctt_f; rewrite -ecdiv_eq0_constant_fraction.
    rewrite [ecdiv _]fg_decomp subr_eq0 => neq.
    have hdeg: deg (fgpos (ecdiv f)) = deg (fgneg (ecdiv f)).
      by apply/eqP; rewrite -subr_eq0 -degB -fg_decomp deg_ecdiv_eq0.
    case: x => [x|]; last first.
      set P := nth ∞ (dom (fgneg (ecdiv f))) 0.
      have P_in: P \in dom (fgneg (ecdiv f)).
        rewrite mem_nth // lt0n size_eq0 dom_eq0.
        apply/eqP=> eq; move: hdeg neq; rewrite eq deg0.
        by move/(fgpos_eq0P (fgpos_le0 _)) => ->; rewrite eqxx.
      exists P.
      + have [//|outcve] := (boolP (oncurve P)); move: P_in.
        by rewrite mem_negdiv order_outcve.
      + by apply order_lt0_eval; rewrite -mem_negdiv.
    have h (g : {fraction ecpoly}):
         fgpos (ecdiv g) != fgneg (ecdiv g)
      -> exists2 P, oncurve P & eval g P = 0%:PP.
      move=> {neq hdeg} neq; set P := nth ∞ (dom (fgpos (ecdiv g))) 0.
      have hdeg: deg (fgpos (ecdiv g)) = deg (fgneg (ecdiv g)).
        by apply/eqP; rewrite -subr_eq0 -degB -fg_decomp deg_ecdiv_eq0.
      have P_in: P \in dom (fgpos (ecdiv g)).
        rewrite mem_nth // lt0n size_eq0 dom_eq0.
        apply/eqP=> eq; move: hdeg neq; rewrite eq deg0 => /esym.
        by move/(fgpos_eq0P (fgneg_le0 _)) => ->; rewrite eqxx.
      exists P.
      + have [//|outcve] := (boolP (oncurve P)); move: P_in.
        by rewrite mem_posdiv order_outcve.
      + by rewrite order_gt0_eval // -mem_posdiv.
    case: (h (f - x%:PEF)).
      by rewrite -subr_eq0 -fg_decomp ecdiv_eq0_constant_fraction fctt_shift.
    move=> P oncve_P eq; exists P => //; move: eq.
    rewrite evalDr evalN evalC //= => /(congr1 (fun y => y \+ x%:PP)).
    by rewrite -Monoid.mulmA /= [-x+_]addrC subrr add0r Monoid.mulm1.
  Qed.

  Lemma injective_comp_poly_fec (h : {fraction ecpoly}) (p1 p2 : {poly K}):
       ~~ constant_fraction h
    -> comp_poly_fec h p1 = comp_poly_fec h p2 -> p1 = p2.
  Proof.
    move=> Nctt_h; move/eqP; rewrite -subr_eq0 -raddfB /=.
    move/eqP; case: (ltnP 1 (size (p1 - p2))); last first.
      rewrite leq_eqVlt; case/orP=> [/size_poly1P [c nz_c ->]|]; last first.
        by rewrite ltnS leqn0 size_poly_eq0 subr_eq0 => /eqP.
      move/eqP; rewrite comp_polyC_fec tofrac_eq0 ecX_eq0.
      by rewrite polyC_eq0 (negbTE nz_c).
    move=> lt1_szp1Bp2; case: (Nctt_surjective [inf] Nctt_h).
    move=> R oncveR eval_hR /(congr1 ((@eval _ _)^~ R)).
    by rewrite eval0 eval_comp_fec // eval_hR.
  Qed.

  Lemma injective_comp_frac_fec (h : {fraction ecpoly}) (f1 f2 : {fraction {poly K}}):
       ~~ constant_fraction h
    -> comp_frac_fec f1 h = comp_frac_fec f2 h -> f1 = f2.
  Proof.
    move=> Nctt_h;
      elim/fracW: f1 => n1 d1 nz_d1;
      elim/fracW: f2 => n2 d2 nz_d2;
    move/eqP=> eq; apply/eqP; move: eq.
    rewrite !comp_frac_fecE // !divff_eq; first last.
    + by rewrite mulf_neq0 //; apply/negP;
           [ move/comp_poly_fec_eq0 => /(_ nz_d1)
           | move/comp_poly_fec_eq0 => /(_ nz_d2) ];
           rewrite (negbTE Nctt_h).
    + by rewrite mulf_neq0 // tofrac_eq0.
    rewrite -!comp_polyM_fec -!tofracM => /eqP.
    by move/injective_comp_poly_fec => /(_ Nctt_h) ->.
  Qed.
End FracECPoly.


Require Import
        Fiat.Common.BoundedLookup.
Require Import
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Formats.Word.
Require Import
        Coq.Vectors.Vector
        Bedrock.Word.

Section Enum.
  Context {len : nat}.
  Context {A : Type}.
  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : MonoidUnit monoid bool}.

  Context {sz : nat}.
  Context {ta : t A (S len)}.
  Variable (tb : t (word sz) (S len)).

  Inductive NoDupVector {A}
    : forall {n}, Vector.t A n -> Prop :=
    NoDupVector_nil : NoDupVector (Vector.nil _)
  | NoDupVector_cons : forall (x : A) {n} (l : Vector.t A n),
      ~ Vector.In x l -> NoDupVector l -> NoDupVector (Vector.cons _ x _ l).

  Lemma NoDupVector_invert {A'}
    : forall n (l : Vector.t A' n),
      NoDupVector l
      -> match l with
         | Vector.nil => True
         | Vector.cons a _ l' =>
           ~ Vector.In a l' /\ NoDupVector l'
         end.
  Proof.
    clear; induction 1; eauto.
  Qed.

  Definition format_enum (i : BoundedIndex ta) (ce : CacheFormat) : B * CacheFormat :=
    let fin := i.(indexb).(ibound)
    in  format_word (nth tb fin) ce.

  Fixpoint word_indexed {n : nat}
           (w : word sz)
           (t : t (word sz) n) : option (Fin.t n)
    := match t in Vector.t _ n return option (Fin.t n) with
       | nil => None
       | cons w' _ t' =>
         if (weqb w w') then Some (Fin.F1) else
           match word_indexed w t' with
           | Some f => Some (Fin.FS f)
           | None => None
           end
       end.

  Definition decode_enum (b : B)
             (cd : CacheDecode)
    : BoundedIndex ta * B * CacheDecode :=
    match decode_word (sz:=sz) b cd with
    | (w, b', cd') =>
      ({| bindex := _;
          indexb := {| ibound := match word_indexed w tb with
                                 | Some i => i
                                 | None => Fin.F1 end;
                       boundi := eq_refl _ |} |}, b', cd')
    end.

  Lemma word_indexed_correct :
    forall n (i : Fin.t n) (t : t (word sz) n),
      NoDupVector t
      -> match word_indexed (nth t i) t with
      | Some w' => i = w'
      | None => False
      end.
  Proof.
    clear.
    induction i.
    - intro; pattern n, t; apply Vector.caseS; simpl; intros.
      rewrite (proj2 (weqb_true_iff h h)); eauto.
    - intro; generalize i (IHi (Vector.tl t)); clear.
      pattern n, t; apply Vector.caseS; simpl.
      intros h n0 t0 i; case_eq (word_indexed (nth t0 i) t0); intros;
        apply NoDupVector_invert in H1; intuition subst.
      case_eq (weqb (nth t0 t1) h); intros; eauto.
      apply weqb_true_iff in H0; subst.
      destruct H2; generalize t0 H; clear; induction t1.
      + intro; pattern n, t0; apply Vector.caseS; simpl; intros; econstructor.
      + intro; revert t1 IHt1; pattern n, t0; apply Vector.caseS;
          simpl; intros.
        case_eq (weqb (nth t t1) h); intros; eauto.
        * apply weqb_true_iff in H0; subst; econstructor.
        * rewrite H0 in H.
          econstructor 2; apply IHt1.
          destruct (word_indexed (nth t t1) t); try discriminate.
          f_equal; apply Fin.FS_inj; congruence.
  Qed.

  Theorem Enum_decode_correct :
    NoDupVector tb
    -> format_decode_correct monoid (fun _ => True) format_enum decode_enum.
  Proof.
    unfold format_decode_correct, format_enum, decode_enum.
    intros ? env env' xenv xenv' data data' bin' ext ext' Eeq PPred Penc Pdec.
    destruct (decode_word (mappend bin' ext) env') as [[? ?] ?] eqn: ?.
    pose proof (Word_decode_correct _ _ _ _ _ _ _ _ _ Eeq I Penc Heqp).
    inversion Pdec; subst; clear Pdec.
    destruct H0 as [? [? ?]].
    repeat split; eauto.
    rewrite <- H1.
    apply (word_indexed_correct _ (ibound (indexb data))) in H.
    destruct (word_indexed (nth tb (ibound (indexb data))) tb); intros.
    rewrite <- H;
    destruct data. destruct indexb. simpl. rewrite <- boundi. reflexivity.
    intuition.
  Qed.
End Enum.