Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import WhileDB.SetsDomain.

(** 本文件为库文件，其中的admit不需要填充 *)

Class Order (A: Type): Type :=
  order_rel: A -> A -> Prop.

Declare Scope order_scope.
Notation "a <= b" := (order_rel a b): order_scope.
Local Open Scope order_scope.

Definition is_lb
             {A: Type} {RA: Order A}
             (X: A -> Prop) (a: A): Prop :=
  forall a', X a' -> a <= a'.

Definition is_ub
             {A: Type} {RA: Order A}
             (X: A -> Prop) (a: A): Prop :=
  forall a', X a' -> a' <= a.

Definition is_omega_lb
             {A: Type} {RA: Order A}
             (l: nat -> A) (a: A): Prop :=
  forall n, a <= l n.

Definition is_omega_ub
             {A: Type} {RA: Order A}
             (l: nat -> A) (a: A): Prop :=
  forall n, l n <= a.

Definition is_omega_lub
             {A: Type} {RA: Order A}
             (l: nat -> A) (a: A): Prop :=
  is_omega_ub l a /\ is_lb (is_omega_ub l) a.

Lemma is_omega_lub_sound:
  forall {A: Type} {RA: Order A} {l: nat -> A} {a: A},
    is_omega_lub l a -> is_omega_ub l a.
Proof. unfold is_omega_lub; intros; tauto. Qed.

Lemma is_omega_lub_tight:
  forall {A: Type} {RA: Order A} {l: nat -> A} {a: A},
    is_omega_lub l a -> is_lb (is_omega_ub l) a.
Proof. unfold is_omega_lub; intros; tauto. Qed.

Class Equiv (A: Type): Type :=
  equiv: A -> A -> Prop.

Notation "a == b" := (equiv a b): order_scope.

Class Reflexive_Setoid
        (A: Type) {RA: Order A} {EA: Equiv A}: Prop :=
  reflexivity_setoid:
    forall a b, a == b -> a <= b.

Class AntiSymmetric_Setoid
        (A: Type) {RA: Order A} {EA: Equiv A}: Prop :=
  antisymmetricity_setoid:
    forall a b, a <= b -> b <= a -> a == b.

Class PartialOrder_Setoid
        (A: Type) {RA: Order A} {EA: Equiv A}: Prop :=
{
  PO_Reflexive_Setoid:> Reflexive_Setoid A;
  PO_Transitive:> Transitive order_rel;
  PO_AntiSymmetric_Setoid:> AntiSymmetric_Setoid A
}.

Instance PartialOrder_Setoid_Proper
           {A: Type} `{POA: PartialOrder_Setoid A} {EquivA: Equivalence equiv}:
  Proper (equiv ==> equiv ==> iff) order_rel.
Proof.
  unfold Proper, respectful.
  intros.
  split; intros.
  + transitivity x0; [| apply reflexivity_setoid; tauto].
    transitivity x; [apply reflexivity_setoid; symmetry; tauto |].
    tauto.
  + transitivity y0; [| apply reflexivity_setoid; symmetry; tauto].
    transitivity y; [apply reflexivity_setoid; tauto |].
    tauto.
Qed.

Lemma same_omega_ub_same_omega_lub:
  forall
    {A: Type}
    `{POA: PartialOrder_Setoid A}
    (l1 l2: nat -> A)
    (a1 a2: A),
  (is_omega_ub l1 == is_omega_ub l2)%sets ->
  is_omega_lub l1 a1 ->
  is_omega_lub l2 a2 ->
  a1 == a2.
Proof.
  intros A ? ? POA.
  sets_unfold.
  intros.
  apply antisymmetricity_setoid.
  + apply (is_omega_lub_tight H0).
    apply H.
    apply (is_omega_lub_sound H1).
  + apply (is_omega_lub_tight H1).
    apply H.
    apply (is_omega_lub_sound H0).
Qed.

Class OmegaLub (A: Type): Type :=
  omega_lub: (nat -> A) -> A.

Class Bot (A: Type): Type :=
  bot: A.

Definition increasing
             {A: Type} {RA: Order A} (l: nat -> A): Prop :=
  forall n, l n <= l (S n).

Definition is_least {A: Type} {RA: Order A} (a: A): Prop :=
  forall a', a <= a'.

Class OmegaCompletePartialOrder_Setoid
        (A: Type)
        {RA: Order A} {EA: Equiv A}
        {oLubA: OmegaLub A} {BotA: Bot A}: Prop :=
{
  oCPO_PartialOrder:> PartialOrder_Setoid A;
  oCPO_completeness: forall T,
    increasing T -> is_omega_lub T (omega_lub T);
  bot_is_least: is_least bot
}.

Lemma same_omega_ub_same_omega_lub':
  forall
    {A: Type}
    `{oCPOA: OmegaCompletePartialOrder_Setoid A}
    (l1 l2: nat -> A),
  (is_omega_ub l1 == is_omega_ub l2)%sets ->
  increasing l1 ->
  increasing l2 ->
  omega_lub l1 == omega_lub l2.
Proof.
  intros.
  apply (same_omega_ub_same_omega_lub _ _ _ _ H).
  + apply oCPO_completeness.
    apply H0.
  + apply oCPO_completeness.
    apply H1.
Qed.

Definition mono
             {A B: Type}
             `{POA: PartialOrder_Setoid A}
             `{POB: PartialOrder_Setoid B}
             (f: A -> B): Prop :=
  forall a1 a2, a1 <= a2 -> f a1 <= f a2.

Definition continuous
             {A B: Type}
             `{oCPOA: OmegaCompletePartialOrder_Setoid A}
             `{oCPOB: OmegaCompletePartialOrder_Setoid B}
             (f: A -> B): Prop :=
  forall l: nat -> A,
    increasing l ->
    f (omega_lub l) == omega_lub (fun n => f (l n)).

Lemma id_mono:
  forall {A: Type}
         `{POA: PartialOrder_Setoid A},
  mono (fun x => x).
Proof.
unfold mono.
intros. tauto.
Qed.

Lemma compose_mono:
  forall {A B C: Type}
         `{POA: PartialOrder_Setoid A}
         `{POB: PartialOrder_Setoid B}
         `{POC: PartialOrder_Setoid C}
         (f: A -> B)
         (g: B -> C),
  mono f -> mono g -> mono (fun x => g (f x)).
Proof.
unfold mono;intros.
pose proof H a1 a2 H1.
pose proof H0 (f a1) (f a2) H2.
tauto.
Qed.

Lemma id_continuous:
  forall {A: Type}
         `{oCPOA: OmegaCompletePartialOrder_Setoid A}
         {EquivA: Equivalence equiv},
  continuous (fun x => x).
Proof.
unfold continuous;intros.
(* pose proof oCPO_completeness l H. *)
assert ((is_omega_ub l == is_omega_ub (fun n:nat => l n))%sets).
{
	unfold   is_omega_ub. reflexivity.
}
pose proof same_omega_ub_same_omega_lub' (l) (fun n:nat=> l n) H0 H.
assert (increasing (fun n:nat=> l n)). {
	unfold increasing.
	unfold increasing in H. tauto.
}
pose proof H1 H2.
tauto. Qed.

Lemma increasing_mono_increasing:
  forall {A B: Type}
         `{POA: PartialOrder_Setoid A}
         `{POB: PartialOrder_Setoid B}
         (f: A -> B)
         (l: nat -> A),
  increasing l -> mono f -> increasing (fun n => f (l n)).
Proof.
intros.
unfold increasing. intros.
unfold increasing in H. intros.
unfold mono in H0.
apply H0. apply H.
Qed.

Lemma mono_equiv_congr:
  forall {A B: Type}
         `{POA: PartialOrder_Setoid A}
         `{POB: PartialOrder_Setoid B}
          {EquivA: Equivalence (equiv: A -> A -> Prop)}
         (f: A -> B),
  mono f -> Proper (equiv ==> equiv) f.
Proof.
intros.
unfold Proper.
unfold respectful. intros.
pose proof reflexivity_setoid x y H0.
unfold mono in H.
apply H in H1.
pose proof reflexivity_setoid y x.
assert (equiv y x).
{
	apply symmetry. tauto.
}
pose proof H2 H3.
apply H in H4.
pose proof antisymmetricity_setoid (f x) (f y) H1 H4.
tauto.
Qed.

Lemma compose_continuous:
  forall {A B C: Type}
         `{oCPOA: OmegaCompletePartialOrder_Setoid A}
         `{oCPOB: OmegaCompletePartialOrder_Setoid B}
         `{oCPOC: OmegaCompletePartialOrder_Setoid C}
          {EquivB: Equivalence (equiv: B -> B -> Prop)}
          {EquivC: Equivalence (equiv: C -> C -> Prop)}
         (f: A -> B)
         (g: B -> C),
  mono f ->
  mono g ->
  continuous f ->
  continuous g ->
  continuous (fun x => g (f x)).
Proof.
unfold continuous;
intros.
pose proof H3.
apply H1 in H3.
pose proof mono_equiv_congr g H0.
apply H5 in H3.
pose proof increasing_mono_increasing f l H4 H.
apply H2 in H6.
rewrite H3.
tauto.
Qed.

Lemma iter_bot_increasing:
  forall
    {A: Type}
    `{oCPOA: OmegaCompletePartialOrder_Setoid A}
    (f: A -> A),
    mono f ->
    increasing (fun n => Nat.iter n f bot).
Proof.
  unfold increasing.
  intros.
  induction n; simpl.
  + apply bot_is_least.
  + apply H.
    apply IHn.
Qed.

Lemma iter_S_bot_increasing:
  forall
    {A: Type}
    `{oCPOA: OmegaCompletePartialOrder_Setoid A}
    (f: A -> A),
    mono f ->
    increasing (fun n => f (Nat.iter n f bot)).
Proof.
  unfold increasing.
  intros.
  apply H.
  apply iter_bot_increasing.
  apply H.
Qed.

Definition BW_LFix
             {A: Type}
             `{CPOA: OmegaCompletePartialOrder_Setoid A}
             (f: A -> A): A :=
  omega_lub (fun n => Nat.iter n f bot).

Lemma BW_LFix_is_fix:
  forall
    {A: Type}
    `{CPOA: OmegaCompletePartialOrder_Setoid A}
    {EquivA: Equivalence equiv}
    (f: A -> A),
    mono f ->
    continuous f ->
    f (BW_LFix f) == BW_LFix f.
Proof.
  unfold BW_LFix; intros.
  rewrite H0 by (apply iter_bot_increasing; tauto).
  apply same_omega_ub_same_omega_lub'.
  + intros; unfold is_omega_ub.
    split; intros.
    - destruct n.
      * apply bot_is_least.
      * apply H1.
    - specialize (H1 (S n)).
      apply H1.
  + apply iter_S_bot_increasing.
    apply H.
  + apply iter_bot_increasing.
    apply H.
Qed.

Lemma BW_LFix_is_least_fix:
  forall
    {A: Type}
    `{CPOA: OmegaCompletePartialOrder_Setoid A}
    {EquivA: Equivalence equiv}
    (f: A -> A)
    (a: A),
    mono f ->
    continuous f ->
    f a == a ->
    BW_LFix f <= a.
Proof.
  unfold BW_LFix; intros.
  pose proof iter_bot_increasing f H.
  pose proof oCPO_completeness (fun n => Nat.iter n f bot) H2.
  apply (is_omega_lub_tight H3).
  unfold is_omega_ub.
  induction n; simpl.
  + apply bot_is_least.
  + rewrite <- H1.
    apply H.
    apply IHn.
Qed.

Local Close Scope order_scope.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_bnd_equ_reduce :
  forall T1 x1 L1, T1 = (t_sel_bnd x1 L1) ->
                  forall T2 L2 T2', T2 = (t_equ L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.


From mathcomp Require Import all_ssreflect all_algebra all_field.

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

Import GRing.Theory.

Local Open Scope ring_scope.

Local Notation has_char0 L := ([char L] =i pred0).

Section Char0MorphismsIdomain.

Variable (R : idomainType).
Hypothesis charR0 : has_char0 R.

Implicit Type z : int.

Lemma char0_intr_eq0 (z : int) : ((z%:~R : R) == 0) = (z == 0).
Proof.
suff hPos (m : nat) : (m%:~R == 0 :> R) = (Posz m == 0).
  by case: z => [m | m] => //; rewrite NegzE rmorphN /= !oppr_eq0.
by rewrite [m%:~R]/(m%:R); move/charf0P: (charR0)->.
Qed.

Lemma char0_intr_inj : injective (fun i => i%:~R : R).
Proof.
move=> i j /eqP; rewrite -subr_eq0 -rmorphB /= char0_intr_eq0 subr_eq0.
by move/eqP.
Qed.

End Char0MorphismsIdomain.

Definition char0_ratr (F : fieldType) (charF0 : has_char0 F) := (@ratr F).

Lemma char0_ratrE (F : fieldType) (charF0 : has_char0 F) :
  char0_ratr charF0 = ratr.
Proof. by []. Qed.

Section Char0MorphismsField.

Variable (F : fieldType).
Hypothesis charF0 : has_char0 F.

Local Notation ratrF := (char0_ratr charF0).

Fact char0_ratr_is_rmorphism : rmorphism ratrF.
Proof.
rewrite /char0_ratr.
have injZtoQ: @injective rat int intr by apply: intr_inj.
have nz_den x: (denq x)%:~R != 0 :> F by rewrite char0_intr_eq0 // denq_eq0.
do 2?split; rewrite /ratr ?divr1 // => x y; last first.
  rewrite mulrC mulrAC; apply: canLR (mulKf (nz_den _)) _; rewrite !mulrA.
  do 2!apply: canRL (mulfK (nz_den _)) _; rewrite -!rmorphM; congr _%:~R.
  apply: injZtoQ; rewrite !rmorphM [x * y]lock /= !numqE -lock.
  by rewrite -!mulrA mulrA mulrCA -!mulrA (mulrCA y).
apply: (canLR (mulfK (nz_den _))); apply: (mulIf (nz_den x)).
rewrite mulrAC mulrBl divfK ?nz_den // mulrAC -!rmorphM.
apply: (mulIf (nz_den y)); rewrite mulrAC mulrBl divfK ?nz_den //.
rewrite -!(rmorphM, rmorphB); congr _%:~R; apply: injZtoQ.
rewrite !(rmorphM, rmorphB) [_ - _]lock /= -lock !numqE.
by rewrite (mulrAC y) -!mulrBl -mulrA mulrAC !mulrA.
Qed.

Canonical char0_ratr_additive  := Additive char0_ratr_is_rmorphism.
Canonical char0_ratr_rmorphism := RMorphism char0_ratr_is_rmorphism.

End Char0MorphismsField.

Section NumberFieldsProps.

Variable (L : fieldExtType rat).

Lemma char_ext : has_char0 L. (* this works more generally for `lalgType rat` *)
Proof. by move=> x; rewrite char_lalg Num.Theory.char_num. Qed.
Hint Resolve char_ext : core.

Lemma rat_extratr0 : ratr 0 = 0 :> L.
(* watch out: no // to discharge charL as it is in Prop :) *)
Proof. by rewrite -char0_ratrE raddf0. Qed.

Notation ratrL := (char0_ratr char_ext).

Lemma char0_ratrN : {morph ratrL : x / - x}. Proof. exact: raddfN. Qed.
Lemma char0_ratrD : {morph ratrL : x y / x + y}. Proof. exact: raddfD. Qed.
Lemma char0_ratrB : {morph ratrL : x y / x - y}. Proof. exact: raddfB. Qed.
Lemma char0_ratrMn n : {morph ratrL : x / x *+ n}. Proof. exact: raddfMn. Qed.
Lemma char0_ratrMNn n : {morph ratrL : x / x *- n}. Proof. exact: raddfMNn. Qed.
Lemma char0_ratr_sum I r (P : pred I) E :
  ratrL (\sum_(i <- r | P i) E i) = \sum_(i <- r | P i) ratrL (E i).
Proof. exact: raddf_sum. Qed.
 Lemma char0_ratrMsign n : {morph ratrL : x / (- 1) ^+ n * x}.
Proof. exact: raddfMsign. Qed.

Lemma char0_ratr1 : ratrL 1 = 1. Proof. by exact: rmorph1. Qed.
Lemma char0_ratrM : {morph ratrL : x y  / x * y}. Proof. by exact: rmorphM. Qed.

Lemma char0_ratr_prod I r (P : pred I) E :
  ratrL (\prod_(i <- r | P i) E i) = \prod_(i <- r | P i) ratrL (E i).
Proof. exact: rmorph_prod. Qed.

Lemma char0_ratrX n : {morph ratrL : x / x ^+ n}.
Proof. exact: rmorphX.  Qed.

Lemma char0_nat n : ratrL n%:R = n%:R. Proof. exact: ratr_nat. Qed.

Lemma char0_ratrN1 : ratrL (- 1) = (- 1). Proof. exact: rmorphN1. Qed.

Lemma char0_ratr_sign n : ratrL ((- 1) ^+ n) = (- 1) ^+ n.
Proof. by exact: rmorph_sign. Qed.

Lemma char0_ratr_inj : injective ratrL.
Proof.
suff inj0 z : ratrL z = 0 -> z = 0.
  move=> x y /eqP; rewrite -subr_eq0 -char0_ratrB => /eqP /inj0 /eqP.
  by rewrite subr_eq0 => /eqP.
rewrite /ratrL /ratr; move/eqP; rewrite mulf_eq0 invr_eq0 orbC.
have /negPf-> /= : (denq z)%:~R != 0 :> L by rewrite char0_intr_eq0 // denq_eq0.
by rewrite char0_intr_eq0 // numq_eq0 => /eqP.
Qed.

Lemma char0_rmorph_int z : ratrL z%:~R =  z%:~R. Proof. exact: rmorph_int. Qed.

(* Are these two necessary? *)
Lemma char0_ratr_eq_nat x n : (ratrL x == n%:R) = (x == n%:R).
Proof. apply: rmorph_eq_nat; exact: char0_ratr_inj. Qed.

Lemma char0_ratr_eq1 x : (ratrL x == 1) = (x == 1).
Proof. exact: char0_ratr_eq_nat 1%N. Qed.

End NumberFieldsProps.

(* Field extensions in characteristic 0 are always separable *)
Section FieldExtChar0.

Variables (F0 : fieldType) (L : splittingFieldType F0).
Variables (charL : has_char0 L).
Implicit Types (E F : {subfield L}) (p : {poly L}) (x : L).

(** Ok **)
Lemma root_make_separable p x : root p x = root (p %/ gcdp p p^`()) x.
Proof.
have [->|p_neq0] := eqVneq p 0; first by rewrite div0p root0.
have := dvdp_gcdl p p^`(); rewrite dvdp_eq => /eqP p_eq_pDgMg.
apply/idP/idP => [rpx|]; last first.
  move=> dx_eq0; rewrite p_eq_pDgMg.
  by rewrite /root hornerM mulf_eq0 (eqP dx_eq0) eqxx.
have [[|m] [q]] := multiplicity_XsubC p x; rewrite p_neq0/= => rNqx p_eq.
  by rewrite p_eq mulr1 (negPf rNqx) in rpx.
have q_neq0 : q != 0; first by apply: contra_eq_neq p_eq => ->; rewrite mul0r.
rewrite p_eq; set f := ('X - _).
have f_neq0 : f != 0 by rewrite polyXsubC_eq0.
rewrite -dvdp_XsubCl derivM deriv_exp/= derivXsubC mul1r.
rewrite -mulr_natl exprS !mulrA -mulrDl.
set r := (_ * f + _)%R.
have Nrx : ~~ root r x.
  rewrite /root !hornerE subrr mulr0 add0r mulf_neq0//.
  have -> : m.+1%:R = m.+1%:R%:P :> {poly L} by rewrite !raddfMn.
  rewrite hornerC natf_neq0/= (eq_pnat _ (eq_negn charL))/=.
  by apply/andP; split => //; apply/allP.
rewrite (eqp_dvdr _ (eqp_divr _ (gcdp_mul2r _ _ _))).
rewrite divp_pmul2r//; last 2 first.
- by rewrite ?expf_neq0 ?polyXsubC_eq0.
- by rewrite ?gcdp_eq0 negb_and ?mulf_neq0.
rewrite mulrC -divp_mulA ?dvdp_mulr//.
have := dvdp_gcdl (f * q) r; rewrite Gauss_dvdpr//.
by rewrite coprimep_XsubC root_gcd (negPf Nrx) andbF.
Qed.

Lemma char0_minPoly_separable x E : separable_poly (minPoly E x).
Proof.
have pE := minPolyOver E x; set p := minPoly E x.
suff /eqp_separable-> : p %= p %/ gcdp p p^`().
  by rewrite make_separable ?monic_neq0 ?monic_minPoly.
rewrite /eqp divp_dvd ?dvdp_gcdl// andbT.
rewrite minPoly_dvdp ?divp_polyOver ?gcdp_polyOver ?polyOver_deriv//.
by rewrite -root_make_separable// root_minPoly.
Qed.

Lemma char0_separable_element x E : separable_element E x.
Proof. exact: char0_minPoly_separable. Qed.

Lemma char0_separable E F : separable E F.
Proof. by apply/separableP => y _; apply: char0_separable_element. Qed.

Lemma char0_galois E F : (E <= F)%VS -> normalField E F -> galois E F.
Proof. by move=> sEF nEF; apply/and3P; split=> //; apply: char0_separable. Qed.

End FieldExtChar0.


Require Import CoRN.algebra.RSetoid.
Require Import CoRN.metric2.Metric.
Require Import CoRN.metric2.UniformContinuity.
Require Import
 Coq.QArith.Qabs CoRN.reals.fast.CRArith CoRN.reals.fast.CRabs.

(** Balls with real radii instead of rational radii. *)

Open Scope CR_scope.

Section contents.

  Context {M: MetricSpace}.

  Definition CRball (r: CR) (x y: M): Prop
    := forall (q:Q), r <= ' q -> ball q x y.

  Global Instance proper: Proper (@msp_eq _ ==> @msp_eq _ ==> @msp_eq _ ==> iff) CRball.
  Proof.
   intros ?? E ?? F ?? G.
   split. intros. intros q H0.
   rewrite <- E in H0.
   specialize (H q H0). rewrite <- F, <- G. exact H.
   intros. intros q H0.
   rewrite E in H0.
   specialize (H q H0). rewrite F, G. exact H.
  Qed.

  Global Instance reflexive (r: CR): CRnonNeg r -> Reflexive (CRball r).
  Proof with auto.
   unfold CRball, Reflexive.
   intros.
   apply ball_refl.
   apply CRle_Qle.
   apply CRle_trans with r...
   apply -> CRnonNeg_le_0...
  Qed.

  Lemma zero (x y: M): msp_eq x y <-> CRball 0 x y.
  Proof with auto.
   split. intros H z zpos.
   apply (@ball_weak_le _ 0). apply CRle_Qle, zpos.
   exact H. intros. apply H. apply CRle_refl.
  Qed.

  Lemma weak_le (r r': CR): r <= r' -> forall x y, CRball r x y -> CRball r' x y.
  Proof. intros ??? E ??. apply E. apply CRle_trans with r'; assumption. Qed.

  Lemma rational (r: Q) (x y: M): ball r x y <-> CRball ('r) x y.
  Proof with auto.
   split...
   repeat intro.
   apply CRle_Qle in H0.
   apply ball_weak_le with r...
   intros. apply H, CRle_refl.
  Qed.

End contents.

(* In the CR metric space, CRball is what you'd expect. *)

Lemma as_distance_bound (r x y: CR): CRball r x y <-> CRdistance x y <= r.
Proof with auto.
 unfold CRball.
 rewrite <- CRdistance_CRle.
 assert ((forall x0 : Q, r <= ' x0 -> x - ' x0 <= y /\ y <= x + ' x0) <->
         x - r <= y /\ y <= x + r).
 split; intros.
 - split.
   + apply CRplus_le_l with (r - y).
     CRring_replace (r - y + (x - r)) (x - y).
     CRring_replace (r - y + y) r.
   apply (proj1 (Qle_CRle_r _ _)).
   intros.
   apply CRplus_le_l with (y - ' y').
   CRring_replace (y - 'y' + (x - y)) (x - 'y').
   CRring_replace (y - 'y' + 'y') y.
   now apply (H y').
   + apply CRplus_le_r with (-x).
  CRring_replace (x + r - x) r.
  apply (proj1 (Qle_CRle_r _ _)). intros.
  apply CRplus_le_l with x.
  CRring_replace (x + (y - x)) y...
  apply H...
 - split.
  apply CRle_trans with (x - r).
  apply CRplus_le_compat...
  apply CRle_refl.
   apply -> CRle_opp...
  apply H.
 apply CRle_trans with (x + r).
  apply H.
 apply CRplus_le_compat...
 apply CRle_refl.
 - split. intros. destruct H. apply H.
   intros; rewrite in_CRgball; intuition.
   intros. destruct H.
   rewrite <- in_CRgball. apply H2; assumption.
Qed. (* todo: clean up *)

Lemma gball_CRabs (r : Q) (x y : CR) : ball r x y <-> CRabs (x - y) <= ' r.
Proof. rewrite rational. apply as_distance_bound. Qed.

Lemma gball_CRmult_Q (e a : Q) (x y : CR) :
  ball e x y -> ball (Qabs a * e) ('a * x) ('a * y).
Proof.
intro A. apply gball_CRabs.
setoid_replace ('a * x - 'a * y) with ('a * (x - y))
  by (unfold canonical_names.equiv, msp_Equiv; ring).
rewrite CRabs_CRmult_Q, <- CRmult_Qmult.
assert (0 <= 'Qabs a) by (apply CRle_Qle, Qabs_nonneg).
apply (orders.order_preserving (CRmult (' Qabs a))).
now apply gball_CRabs.
Qed.

Lemma gball_CRmult_Q_nonneg (e a : Q) (x y : CR) :
  (0 <= a)%Q -> ball e x y -> ball (a * e) ('a * x) ('a * y).
Proof.
intros A1 A2. rewrite <- (Qabs_pos a) at 1; [apply gball_CRmult_Q |]; easy.
Qed.

Module notations.

  Notation CRball := CRball.

End notations.


Require Import maps.
Require Import String.
Require Import List.
Require Import NPeano.

Set Implicit Arguments.

(* Working towards a proof-by-reflection version of equate_maps, compare maps.v

   For now, importing this module replaces the normalization in maps.v
 *)

Fixpoint merge {A} (le : A -> A -> bool) (l1 l2 : list A) : list A :=
  match l1 with
    | nil => l2
    | (cons v1 l1') =>
      (fix scan l2 :=
         match l2 with
           | nil => l1
           | cons v2 l2' =>
             if le v1 v2
             then cons v1 (merge le l1' l2)
             else cons v2 (scan l2')
         end) l2
  end.
Arguments merge A le !l1 !l2.

Definition mergeTest
 : merge NPeano.ltb (cons 1 (cons 3 (cons 4 nil))) (cons 0 (cons 2 (cons 5 nil)))
 = cons 0 (cons 1 (cons 2 (cons 3 (cons 4 (cons 5 nil)))))
 := eq_refl _.

(* Map representation and interpretation *)
Section MapRep.
  Variables Key Val : Type.

Inductive item_rep : Type :=
  | item (k : nat) (v : Val)
  | submap (m : nat)
  | evar (e : Map Key Val)
  .
Inductive map_rep : Type :=
  | empty
  | join (l r : map_rep)
  | atom (a : item_rep)
  .

Definition interp_item keys submaps (i : item_rep) : Map Key Val :=
  match i with
    | item k v =>
      match nth_error keys k with
        | Some k => k |-> v
        | None => mapEmpty
      end
    | submap m =>
      match nth_error submaps m with
        | Some m => m
        | _ => mapEmpty
      end
    | evar e => e
  end.

Definition interp keys submaps : map_rep -> Map Key Val :=
  fix eval m := match m with
    | empty => mapEmpty
    | join l r => eval l :* eval r
    | atom a => interp_item keys submaps a
  end.

Definition mapEq keys submaps ml mr : Prop :=
     interp keys submaps ml
  ~= interp keys submaps mr.

Definition item_le (i1 i2 : item_rep) : bool :=
  match i1, i2 with
    | item k v, item k2 v2 => leb k k2
    | item _ _, _ => true
    | submap _, item _ _ => false
    | submap m, submap m2 => leb m m2
    | submap _, _ => true
    | evar _, evar _ => true
    | evar _, _ => false
  end.

(* Drop empties, and sort things into the order we want *)
Fixpoint canonicalize (m : map_rep) : list item_rep :=
  match m with
    | empty => nil
    | join l r => merge item_le (canonicalize l) (canonicalize r)
    | atom a => cons a nil
  end.

Definition joins (l : list map_rep) :=
  match l with
    | nil => empty
    | r :: nil => r
    | _ => fold_right join empty l
  end.
Arguments joins l : simpl never.

Fixpoint joins2 (l : list map_rep) :=
  match l with
    | nil => empty
    | r :: nil => r
    | r :: rs => join r (joins2 rs)
  end.
  Functional Scheme joins2_ind := Induction for joins2 Sort Prop.

  Section Equivalence.
  Variable keys : list Key.
  Variable submaps : list (Map Key Val).

  Local Notation int := (interp keys submaps).

  Lemma merge_ {A} (lt : A -> A -> bool) (f : A -> map_rep) (l1 l2 : list A) :
    int (fold_right join empty (map f (merge lt l1 l2)))
        ~= int (join (fold_right join empty (map f l1))
               (fold_right join empty (map f l2))).
  revert l2; induction l1; intro.
  simpl; rewrite equivUnitL; reflexivity.

  induction l2.
  simpl;rewrite equivUnit;reflexivity.
  simpl;destruct (lt a a0);
  simpl;rewrite ?IHl1,?IHl2;simpl;equate_maps.
  Qed.

  Lemma joins_joins2 l : int (fold_right join empty l) ~= int (joins2 l).
  Proof.
    functional induction (joins2 l).
    reflexivity.
    apply equivUnit.
    simpl;rewrite IHm;reflexivity.
  Qed.

  Lemma canon_equiv : forall m, int m ~= int (fold_right join empty (map atom (canonicalize m))).
  Proof.
    induction m;simpl;rewrite ?equivUnit, ?equivUnitL; try reflexivity.
    rewrite IHm1, IHm2, merge_. reflexivity.
  Qed.

  Lemma map_simplify: forall m1 m2,
    int (joins2 (map atom (canonicalize m1))) ~= int (joins2 (map atom (canonicalize m2)))
    -> int m1 ~= int m2.
  intros. rewrite canon_equiv, joins_joins2, H, <- joins_joins2, <- canon_equiv. reflexivity.
  Qed.
  End Equivalence.
End MapRep.

Ltac inList x xs :=
  match xs with
      | nil => false
      | x :: _ => true
      | _ :: ?xs' => inList x xs'
  end.
Ltac insert x xs :=
  match inList x xs with
    | true => xs
    | false => constr:(x :: xs)
  end.
Ltac index x xs :=
  match xs with
    | (x :: _) => constr:0
    | (?x' :: ?xs) => let ix := index x xs in constr:(S ix)
  end.
Ltac gatherKeys gathered t :=
  match t with
    | ?l :* ?r => let gathered' := gatherKeys gathered l in gatherKeys gathered' r
    | (?k |-> _) => insert k gathered
    | _ => gathered
  end.
Ltac gatherSubmaps gathered t k :=
  match t with
    | ?l :* ?r =>
      gatherSubmaps gathered l ltac:(fun gathered' =>
      gatherSubmaps gathered' r k)
    | (_ |-> _) => k gathered
    | ?m =>
      first [is_evar m; k gathered
            | let gathered' := insert m gathered in k gathered'
            ]
  end.

Ltac quoteMap K V keys maps t k :=
  match t with
    | (@mapEmpty _ _) => let rep := constr:(empty K V) in k rep
    | ?l :* ?r =>
      quoteMap K V keys maps l ltac:(fun repl =>
      quoteMap K V keys maps r ltac:(fun repr =>
      let rep := constr:(join repl repr) in k rep
      ))
    | ?key |-> ?v =>
      let repk := index key keys in
      let rep := constr:(atom (item K repk v))
      in k rep
    | ?m =>
      first [is_evar m;
             let rep := constr:(atom (evar m))
             in k rep
            |let repm := index m maps in
             let rep := constr:(atom (submap K V repm))
             in k rep]
  end.
Ltac quote_map_equation := match goal with
    [|- @MapEquiv ?K ?V ?l ?r ] =>
    let ks := gatherKeys (@nil K) l in
    let ks := gatherKeys ks r in
    gatherSubmaps (@nil (Map K V)) l ltac:(fun ms =>
    gatherSubmaps ms r ltac:(fun ms =>
    quoteMap K V ks ms l ltac:(fun repl =>
    quoteMap K V ks ms r ltac:(fun repr =>
      change (interp ks ms repl ~= interp ks ms repr)))))
end.

Definition quote_test0
  : forall (k1 : string) (v1 : nat),
    k1 |-> v1 ~= k1 |-> v1.
Proof.
intros.
quote_map_equation.
reflexivity.
Qed.

Definition quote_test1
  : forall (m : Map string nat),
    m ~= m.
Proof.
intros.
quote_map_equation.
reflexivity.
Qed.

Definition quote_test2
  : forall (m : Map string nat), exists m2, m ~= m2.
Proof.
intros.
eexists.
quote_map_equation.
simpl.
reflexivity.
Qed.

Definition simplify_test1
  : forall (k1 k2 : string) (v1 v2 : nat) (m1 : Map string nat),
    exists m1',
    exists v2',
    k1 |-> v1 :* m1 :* k2 |-> v2 ~= m1' :* k2 |-> v2' :* k1 |-> v1.
Proof.
intros.
eexists.
eexists.
quote_map_equation.
apply map_simplify.
simpl joins2.
simpl interp.
reflexivity.
Qed.

Ltac canonicalize_maps := quote_map_equation;apply map_simplify;simpl interp.

Ltac prepare_maps ::=
  match goal with
    | [|- ?l ~= ?r] => expand_map l;expand_map r
  end;
  canonicalize_maps;
  (* switch if left side has a map evar *)
  match goal with
    | [|- ?l ~= ?r] =>
        match l with
          | context [?v] => is_evar v;
            match type of v with Map _ _  => symmetry end
        end
    | _ => idtac
  end
  .

(*
Fixpoint removeMatches' {A} (cmp : A -> A -> comparison) (l1 l2 l1_acc l2_acc : list A) : (list A * list A) :=
  match l1 with
    | nil => (rev l1_acc, rev_append l2_acc l2)
    | (cons v1 l1') =>
      (fix scan l2 l2_acc {struct l2} :=
         match l2 with
           | nil => (rev_append l1_acc l1, rev l2_acc)
           | cons v2 l2' =>
             match cmp v1 v2 with
               | Lt => removeMatches' cmp l1' l2 (v1::l1_acc) l2_acc
               | Eq => removeMatches' cmp l1' l2' l1_acc l2_acc
               | Gt => scan l2' (v2::l2_acc)
             end
         end) l2 l2_acc
  end.

Definition removeMatches {A} cmp (l1 l2 : list A) := removeMatches' cmp l1 l2 nil nil.

Fixpoint removeMatches'' {A} (cmp : A -> A -> comparison)
         (l1 l2 : list A) eq_acc (l1_acc l2_acc : list A)
  : (list (A * A) * list A * list A) :=
  match l1 with
    | nil => (rev eq_acc, rev l1_acc, rev_append l2_acc l2)
    | (cons v1 l1') =>
      (fix scan l2 eq_acc l2_acc {struct l2} :=
         match l2 with
           | nil => (rev eq_acc, rev_append l1_acc l1, rev l2_acc)
           | cons v2 l2' =>
             match cmp v1 v2 with
               | Lt => removeMatches'' cmp l1' l2 eq_acc (v1::l1_acc) l2_acc
               | Eq => removeMatches'' cmp l1' l2' ((v1,v2)::eq_acc) l1_acc l2_acc
               | Gt => scan l2' eq_acc (v2::l2_acc)
             end
         end) l2 eq_acc l2_acc
  end.

Definition test2 :
  removeMatches Nat.compare (cons 1 (cons 3 (cons 4 nil))) (cons 0 (cons 1 (cons 2 (cons 4 nil))))
  = (cons 3 nil, cons 0 (cons 2 nil)) := eq_refl _.

Definition item_cmp (i1 i2 : item_rep) : comparison :=
  match i1, i2 with
    | item k v, item k2 v2 =>
      match Nat.compare k k2 with
        | Eq => Nat.compare v v2
        | o => o
      end
    | item _ _, submap _ => Lt
    | submap _, item _ _ => Gt
    | submap m, submap m2 => Nat.compare m m2
  end.

Lemma item_cmp_prop : forall i1 i2, item_cmp i1 i2 = Eq -> i1 = i2.
Proof.
destruct i1;destruct i2;simpl;unfold Nat.compare;
repeat match goal with [|-context [Compare_dec.nat_compare ?x ?y]] =>
                   destruct (Compare_dec.nat_compare_spec x y) end;
congruence.
Qed.

  Section RemoveEquiv.
    Variable m1 m2 : map_rep. (* Need a rest of map to make this flexible enough *)

  Local Notation build_equiv l1 l2 := (int (joins (m1 :: map atom l1)) ~= int (joins (m2 :: map atom l2))).

  Lemma app_equiv l1 l2 : int (joins (l1 ++ l2)) ~= int (joins l1) :* int (joins l2).
    induction l1.
    simpl; rewrite equivUnitL; reflexivity.
    simpl app. rewrite !joins_cons.
    rewrite IHl1, equivAssoc; reflexivity.
  Qed.

  Lemma removeEquivSubmaps (l1 l2 l1_acc l2_acc : list item_rep) :
    match removeMatches' item_cmp l1 l2 l1_acc l2_acc with
      | (l1', l2') => build_equiv l1' l2'
    end ->
    build_equiv (rev_append l1_acc l1) (rev_append l2_acc l2).
  revert l1_acc l2 l2_acc;induction l1.
  simpl; intros; rewrite <- rev_alt; assumption.
  induction l2.
  simpl; intros; rewrite <- rev_alt; assumption.
  intros; simpl in * |- *. fold joins.
  destruct (item_cmp a a0) eqn:Hcmp.
  (* Both step? *)
  (* Eq -> goes back to outer IH, with thing dropped *)
  specialize (IHl1 _ _ _ H); clear -Hcmp IHl1.
    (* rearranging. *)
    apply item_cmp_prop in Hcmp. subst a.
    rewrite !rev_append_rev, !map_app, !joins_cons, !app_equiv in IHl1 |- *.
    simpl. rewrite !joins_cons.
    unfold interp;fold int.
    repeat rewrite (equivComAssoc _ (interp_item _ _ _ a0) _).
    rewrite IHl1. reflexivity.
  (* Lt -> use outer IH? *)
  apply IHl1 with (l1_acc := (a :: l1_acc)).
  assumption.
  (* Gt -> use inner IH *)
  apply (IHl2 (a0 :: l2_acc)).
  apply H.
  Qed.
  End RemoveEquiv.

  Lemma reduce_equiv (rep1 rep2 : map_rep) :
    match removeMatches item_cmp (canonicalize rep1) (canonicalize rep2) with
      | (items1, items2) =>
        int (joins (map atom items1)) ~= int (joins (map atom items2))
    end
    -> int rep1 ~= int rep2.
  Proof.
    unfold removeMatches; intros.
    rewrite (canon_equiv rep1), (canon_equiv rep2).
    setoid_rewrite <- equivUnitL.
    change mapEmpty with (int empty).
    rewrite <- 2! joins_cons.
    change (int (joins (empty :: map atom (rev_append nil (canonicalize rep1))))
         ~= int (joins (empty :: map atom (rev_append nil (canonicalize rep2))))).
    apply removeEquivSubmaps.
    destruct (removeMatches' item_cmp (canonicalize rep1)
         (canonicalize rep2) nil nil).
    rewrite 2! joins_cons, H;reflexivity.
  Qed.
End Equivalence.

Definition test3 : forall (k1 k2 : string) (v1 v2 : nat) (m1 : Map string nat),
                     k1 |-> v1 :* m1 :* k2 |-> v2 ~= m1 :* k2 |-> v2 :* k1 |-> v1.
Proof.
intros.
change
  (interp (k1 :: k2 :: nil) (v1 :: v2 ::nil) (m1 :: nil)
        (join (atom (item 0 0)) (join (atom (submap 0)) (atom (item 1 1))))
     ~=
  interp (k1 :: k2 :: nil) (v1 :: v2 ::nil) (m1 :: nil)
        (join (atom (submap 0)) (join (atom (item 1 1)) (atom (item 0 0))))).
apply reduce_equiv.
simpl.
reflexivity.
Qed.

Definition test4 : forall (k1 k2 : string) (v1 v2 : nat) (m1 : Map string nat),
                     k1 |-> v1 :* m1 :* k2 |-> v2 ~= m1 :* k2 |-> v2 :* k1 |-> v1.
Proof.
intros.
quote_map_equation.
apply reduce_equiv.
simpl.
reflexivity.
Qed.
*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e489m21_19limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e488m17_10limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.


Open Scope type_scope.

Section Iso_axioms.

Variables A B C : Set.

Axiom Com : A * B = B * A.
Axiom Ass : A * (B * C) = A * B * C.
Axiom Cur : (A * B -> C) = (A -> B -> C).
Axiom Dis : (A -> B * C) = (A -> B) * (A -> C).
Axiom P_unit : A * unit = A.
Axiom AR_unit : (A -> unit) = unit.
Axiom AL_unit : (unit -> A) = A.

Lemma Cons : B = C -> A * B = A * C.
Proof.
    intros H. rewrite H. reflexivity.
Qed.

End Iso_axioms.

(* Need more recent version of coq it seems *)
Ltac simplify_type ty :=
    match ty with
    | ?A * ?B * ?C  => rewrite <- (Ass A B C); try simplify_type_eq
    end
with simplify_type_eq :=
    match goal with
    | |- ?A = ?B => try symplify_type A; try symplify_type B
    end.


Require Import Bool List Arith Nat.
Import ListNotations.
Require Import Mmx.ast_instructions Mmx.binary Mmx.association_list.

Require Import Mmx.ast_instructions.
Require Import Mmx.binary.

(* (* functions to encode decode instructions *) *)
(* (* TODO :: Here this function can't be call for immediate *) *)
Definition operand_to_bin (o : operande) : option (list bool) :=
  match o with
    | imm_o (imm k) => n_bit 8 k
    | reg_o (reg k) => n_bit 8 k
  end.

Definition operand_to_bin_double (o : operande) : option (list bool) :=
  match o with
  | imm_o (imm k) => n_bit 16 k
  | reg_o (reg k) => n_bit 16 k
  end.

(* -----------------------------------now for instr_operande_t_n ----------------------------------*)
Lemma operand_to_bin_hypothesis_reg : forall (l : list bool) (r : register),
    operand_to_bin (reg_o r) = Some l -> reg (bit_n l) = r.
Proof.
  intros.
  unfold operand_to_bin in H.
  destruct r.
  Search (n_bit).
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

Lemma operand_to_bin_hypothesis_imm : forall (l : list bool) (i : imediate),
    operand_to_bin (imm_o i) = Some l -> imm (bit_n l) = i.
Proof.
  intros.
  unfold operand_to_bin in H.
  destruct i.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

Lemma operand_to_bin_double_hypothesis_reg : forall (l : list bool) (r : register),
    operand_to_bin_double (reg_o r) = Some l -> reg (bit_n l) = r.
Proof.
  intros.
  unfold operand_to_bin_double in H.
  destruct r.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

Lemma operand_to_bin_double_hypothesis_imm : forall (l : list bool) (i : imediate),
    operand_to_bin_double (imm_o i) = Some l -> imm (bit_n l) = i.
Proof.
  intros.
  unfold operand_to_bin_double in H.
  destruct i.
  apply n_bit_n in H.
  rewrite H.
  reflexivity.
Qed.

(* -----------------------------------Other operand_to_bin lemma ----------------------------------*)
Lemma operand_to_bin_size : forall (o : operande) (l : list bool),
    operand_to_bin o = Some l -> length l = 8.
Proof.
  destruct o.
  -unfold operand_to_bin.
   intros l H.
   destruct i in H.
   apply size_n_bit in H.
   rewrite H.
   reflexivity.
   -unfold operand_to_bin.
    intros l H.
    destruct r in H.
    apply size_n_bit in H.
    rewrite H.
    reflexivity.
Qed.

Lemma operand_to_bin_double_size : forall (o : operande) (l : list bool),
    operand_to_bin_double o = Some l -> length l = 16.
Proof.
  destruct o.
  -unfold operand_to_bin.
   intros l H.
   destruct i in H.
   apply size_n_bit in H.
   rewrite H.
   reflexivity.
   -unfold operand_to_bin.
    intros l H.
    destruct r in H.
    apply size_n_bit in H.
    rewrite H.
    reflexivity.
Qed.

(* HERE i don't make any garantee about the result if the binary_instruction is to small but i will have some lemma to give it *)
Fixpoint get_first_n_bit  (bi : list bool) (size : nat) : (list bool*list bool) :=
  match size with
  | 0 => ([],bi)
  | S n => match bi with
           | h :: tl => match get_first_n_bit tl n with
                        | (l1,l2) => (h :: l1,l2)
                        end
           | [] => ([],[])
           end
  end.
Definition testList := [true ; false ; true ; false ; false ; false ; true ; true ].
Definition testList' := [true ; false ; true].

Lemma get_first_n_bit_size_nil_n : forall (n : nat) (l : list bool), length l = n -> get_first_n_bit l n= (l,[]).
Proof.
  induction n.
  -intros.
   Search (length _ = 0).
   apply length_zero_iff_nil in H.
   rewrite H.
   reflexivity.
  -intros.
   unfold get_first_n_bit.
   destruct l.
   +reflexivity.
   +fold get_first_n_bit.
    assert (get_first_n_bit l n = (l,[])) by (apply IHn; auto).
    rewrite H0.
    reflexivity.
Qed.

Lemma get_first_n_bit_size_tl : forall  (n : nat) (l : list bool) (tl : list bool), length l = n -> get_first_n_bit (l ++ tl) n = (l,tl).
Proof.
  induction n.
  -intros.
   apply length_zero_iff_nil in H.
   rewrite H.
   simpl.
   destruct tl.
   +reflexivity.
   +reflexivity.
  -intros.
   unfold get_first_n_bit.
   destruct l.
   fold get_first_n_bit.
   +discriminate.
   +simpl.
    fold get_first_n_bit.
    assert (get_first_n_bit (l ++ tl) n = (l,tl)).
    {
      apply IHn.
      simpl in H.
      inversion H.
      reflexivity.
    }
    rewrite H0.
    reflexivity.
Qed.

Lemma get_first_n_bit_size_4 : forall (l1 l2 l3 l4 : list bool),
    length l1 = 8 -> get_first_n_bit (l1 ++ l2 ++ l3 ++ l4) 8 = (l1,l2 ++ l3 ++ l4).
Proof.
  intros.
  specialize (get_first_n_bit_size_tl 8 l1 (l2 ++ l3 ++ l4)).
  intros.
  auto.
Qed.

Lemma get_first_n_bit_size_3 : forall (n : nat) (l1 l2 l3 : list bool),
    length l1 = n -> get_first_n_bit (l1 ++ l2 ++ l3) n = (l1,l2 ++ l3).
Proof.
  intros.
  specialize (get_first_n_bit_size_tl n l1 (l2 ++ l3)).
  intros.
  auto.
Qed.

(* Lemma get_first_n_bit_size : forall (bi : list bool) (size : nat), n < (length bi) -> get_first_n_bit bi n = ( *)

Definition M A := option A.

Definition ret {A} (a : A) : M A := Some a.

Lemma ret_rewrite : forall (A : Type) (a : A), ret a = Some a.
Proof. intros. unfold ret. reflexivity. Qed.

Definition bind {A B} (ma : M A)(k : A -> M B): M B :=
  match ma with
  | Some a => k a
  | None => None
  end.
Check bind.

Lemma bind_rewrite : forall (A B : Type) (ma : M A) (k : A -> M B) (res : B), bind ma k = Some res -> exists (a : A), k a = Some res /\ Some a = ma.
  intros.
  remember ma.
  destruct m.
  -exists a.
   split.
   +rewrite <- H.
    reflexivity.
   +reflexivity.
  -simpl in H.
   discriminate.
Qed.

(* TODO :: to delete but can't find this theorem so proof of it *)
Lemma commut_equal : forall (A : Type) (a b : A), a = b -> b = a.
Proof.
  intros. rewrite H. reflexivity. Qed.

Notation "'let!' x ':=' ma 'in' k" := (bind ma (fun x => k)) (at level 30).

(* TODO :: here i know that i can always get a binary_instruction but some function don't allow me to  *)
(* return a binary_instruction without encapsulate it into an option type *)

(* theese are the encode functions for the different type of instruction *)

Definition encode_t_n (i : instruction_tern_n) : option binary_instruction :=
  let! k := lookup (tag_t_n (i.(instr_opcode_t_n))) encdec in
  let! code := n_bit 8 k in
  let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_n)) in
  let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_n)) in
  let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_n)) in
  ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i (i : instruction_tern_i) : option binary_instruction :=
  let! k := lookup (tag_t_i (i.(instr_opcode_t_i))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i)) in
                       fun o1 => let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i)) in
                                 fun o2 => let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i)) in
                                           fun o3 => ret (code ++ o1 ++ o2 ++ o3).
Definition encode_t_i2 (i : instruction_tern_i2) : option binary_instruction :=
  let! k := lookup (tag_t_i2 (i.(instr_opcode_t_i2))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i2)) in
                       fun o1 => let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i2)) in
                                 fun o2 => let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_i2)) in
                                           fun o3 => ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i3 (i : instruction_tern_i3) : option binary_instruction :=
  let! k := lookup (tag_t_i3 (i.(instr_opcode_t_i3))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i3)) in
                       fun o1 => let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i3)) in
                                 fun o2 => let! o3 := operand_to_bin (reg_o i.(instr_operande3_t_i3)) in
                                           fun o3 => ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i4 (i : instruction_tern_i4) : option binary_instruction :=
  let! k := lookup (tag_t_i4 (i.(instr_opcode_t_i4))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (reg_o i.(instr_operande1_t_i4)) in
                       fun o1 => let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i4)) in
                                 fun o2 => let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i4)) in
                                           fun o3 => ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i5 (i : instruction_tern_i5) : option binary_instruction :=
  let! k := lookup (tag_t_i5 (i.(instr_opcode_t_i5))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i5)) in
                       fun o1 => let! o2 := operand_to_bin (imm_o i.(instr_operande2_t_i5)) in
                                 fun o2 => let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i5)) in
                                           fun o3 => ret (code ++ o1 ++ o2 ++ o3).

Definition encode_t_i6 (i : instruction_tern_i6) : option binary_instruction :=
  let! k := lookup (tag_t_i6 (i.(instr_opcode_t_i6))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (imm_o i.(instr_operande1_t_i6)) in
                       fun o1 => let! o2 := operand_to_bin (reg_o i.(instr_operande2_t_i6)) in
                                 fun o2 => let! o3 := operand_to_bin (imm_o i.(instr_operande3_t_i6)) in
                                           fun o3 => ret (code ++ o1 ++ o2 ++ o3).

Definition encode_d_n (i : instruction_duo_n) : option binary_instruction :=
  let! k := lookup (tag_d_n (i.(instr_opcode_d_n))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (reg_o i.(instr_operande1_d_n)) in
                       fun o1 => let! o2 := operand_to_bin_double (reg_o i.(instr_operande2_d_n)) in
                                 fun o2 => ret (code ++ o1 ++ o2).

Definition encode_d_i (i : instruction_duo_i) : option binary_instruction :=
  let! k := lookup (tag_d_i (i.(instr_opcode_d_i))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (reg_o i.(instr_operande1_d_i)) in
                       fun o1 => let! o2 := operand_to_bin_double (imm_o i.(instr_operande2_d_i)) in
                                 fun o2 => ret (code ++ o1 ++ o2).

Definition encode_d_i2 (i : instruction_duo_i2) : option binary_instruction :=
  let! k := lookup (tag_d_i2 (i.(instr_opcode_d_i2))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (imm_o i.(instr_operande1_d_i2)) in
                       fun o1 => let! o2 := operand_to_bin_double (reg_o i.(instr_operande2_d_i2)) in
                                 fun o2 => ret (code ++ o1 ++ o2).

Definition encode_d_i3 (i : instruction_duo_i3) : option binary_instruction :=
  let! k := lookup (tag_d_i3 (i.(instr_opcode_d_i3))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => let! o1 := operand_to_bin (imm_o i.(instr_operande1_d_i3)) in
                       fun o1 => let! o2 := operand_to_bin_double (imm_o i.(instr_operande2_d_i3)) in
                                 fun o2 => ret (code ++ o1 ++ o2).
Print operand_to_bin.

Definition encode_u (i : instruction_uno) : option binary_instruction :=
  let! k := lookup (tag_u (i.(instr_opcode_s))) encdec in
  fun k => let! code := n_bit 8 k in
           fun code => match (i.(instr_operande)) with
                         | imm im => let! o := n_bit 24 im in
                                     fun o => ret (code ++ o)
                       end.

(* now the general encode function which take a general instruction *)

Definition encode (i : instruction) : option binary_instruction :=
  match i with
  | instr_t_n t => encode_t_n t
  | instr_t_i t => encode_t_i t
  | instr_t_i2 t => encode_t_i2 t
  | instr_t_i3 t => encode_t_i3 t
  | instr_t_i4 t => encode_t_i4 t
  | instr_t_i5 t => encode_t_i5 t
  | instr_t_i6 t => encode_t_i6 t
  | instr_d_n t => encode_d_n t
  | instr_d_i t => encode_d_i t
  | instr_d_n2 t => encode_d_i2 t
  | instr_d_n3 t => encode_d_i3 t
  | instr_u t => encode_u t
  end.

(* this is the decode function (with this one we only need one general function) *)
Definition decode (bi : binary_instruction) : option instruction :=
  if length bi =? 32
  then
  match get_first_n_bit bi 8 with
  | (li,next) => let! t := lookdown (bit_n li) encdec in
                 fun t => match t with
                          | tag_u u => match get_first_n_bit next 24 with
                                       | (op,[]) =>
                                         ret (instr_u (mk_instr_uno u (imm (bit_n op))))
                                       | _ => None
                                       end
                          | tag_t_n tn =>
                            match get_first_n_bit next 8 with
                            | (op1,next) =>match get_first_n_bit next 8 with
                                           | (op2,next) => match get_first_n_bit next 8 with
                                                           | (op3,[]) =>
                                                             ret (instr_t_n (mk_instr_t_n tn
                                                                                (reg (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                           | _ => None
                                                           end
                                           end
                            end
                            | tag_t_i ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i (mk_instr_t_i ti
                                                                                (reg (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end

                                             end
                              end
                            | tag_t_i2 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                               | (op2,next) => match get_first_n_bit next 8 with
                                                               | (op3,[]) =>
                                                                 ret (instr_t_i2 (mk_instr_t_i2 ti
                                                                                (reg (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                               | _ => None
                                                               end
                                             end
                              end
                            | tag_t_i3 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i3 (mk_instr_t_i3 ti
                                                                                (imm (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (reg (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i4 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i4 (mk_instr_t_i4 ti
                                                                                (reg (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end

                                             end
                              end
                            | tag_t_i5 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i5 (mk_instr_t_i5 ti
                                                                                (imm (bit_n op1))
                                                                                (imm (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_t_i6 ti =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 8 with
                                             | (op2,next) => match get_first_n_bit next 8 with
                                                             | (op3,[]) =>
                                                               ret (instr_t_i6 (mk_instr_t_i6 ti
                                                                                (imm (bit_n op1))
                                                                                (reg (bit_n op2))
                                                                                (imm (bit_n op3))))
                                                             | _ => None
                                                             end
                                             end
                              end
                            | tag_d_i di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_i (mk_instr_d_i di
                                                                            (reg (bit_n op1))
                                                                            (imm (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_i2 di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n2 (mk_instr_d_i2 di
                                                                              (imm (bit_n op1))
                                                                              (reg (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_i3 di =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n3 (mk_instr_d_i3 di
                                                                              (imm (bit_n op1))
                                                                              (imm (bit_n op2))))
                                             | _ => None
                                             end
                              end
                            | tag_d_n dn =>
                              match get_first_n_bit next 8 with
                              | (op1,next) =>match get_first_n_bit next 16 with
                                             | (op2,[]) =>
                                               ret (instr_d_n (mk_instr_d_n dn
                                                                            (reg (bit_n op1))
                                                                            (reg (bit_n op2))))
                                             | _ => None
                                             end
                              end
                          end
  end
  else None.

(* little test (this is the end of the file) *)

(* flux d'instruction il faut faire une fonction qui decode le debut de la liste et retourne la suite de la liste *)
Print fold_right.
Fixpoint cut32_n (n : nat) (l : list bool) : (list (list bool)) :=
  match n with
  | 0 => []
  | S n' => (firstn 32 l) :: (cut32_n n' (skipn 32 l))
  end.

Definition cut32 (l : list bool) : option (list (list bool)) :=
  let n := length l in
  if n mod 32 =? 0 then Some (cut32_n (n / 32) l) else None.

(* i make the option choice because it's easyer for the proof *)
Fixpoint concat_listes_32 (l : list (list bool)) : option (list bool) :=
  match l with
  | [] => Some []
  | h :: tl => let! res := concat_listes_32 tl in
               fun res => if length h =? 32 then Some (h ++ res)
               else None
  end.

Compute cut32 [].
Compute concat_listes_32 [].
Definition test_liste := [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true].
Compute length test_liste.
Definition test_liste2 := [false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false;false].
Compute length test_liste2.
Compute cut32 (test_liste2 ++ test_liste).

Fixpoint check_length_32 (l : list (list bool)) : bool :=
  match l with
  | [] => true
  | l' :: tl => (length l' =? 32) && check_length_32 tl
  end.

(* other way to define encode_flux*)

Fixpoint traverse {A} (l : list (option A)) : option (list A) :=
  match l with
  | [] => Some []
  | (Some e) :: tl => match traverse tl with
                      | Some l => Some (e :: l)
                      | None => None
                      end
  | None :: _ => None
  end.

(* encode_flux definitions *)
Definition encode_flux_opt (li : list instruction) : list (option binary_instruction) :=
  map encode li.
Definition encode_flux (li : list instruction) : option (list binary_instruction) :=
  traverse (encode_flux_opt li).

Definition encode_flux_b (li : list instruction) : option (list bool) :=
  match encode_flux li with
  | None => None
  | Some res => concat_listes_32 res
  end.

Definition decode_flux_opt (lbi : list binary_instruction) : list (option instruction) :=
  map decode lbi.
Definition decode_flux_decoup (lbi : list binary_instruction) : option (list instruction) :=
  traverse (decode_flux_opt lbi).
Definition decode_flux (lb : list bool) : option (list instruction) :=
  let! lbi := cut32 lb in
  fun lbi =>
    decode_flux_decoup lbi.

(* Some little tests about encode and decode_flux *)

Definition my_instr := instr_t_n (mk_instr_t_n AND (reg 10) (reg 11) (reg 12)).
Definition my_instr2 := instr_t_n (mk_instr_t_n ADD (reg 1) (reg 2) (reg 3)).
Definition my_instr_liste := [my_instr;my_instr;my_instr;my_instr2].

Compute traverse (encode_flux_opt my_instr_liste).

Definition my_instr_list_encoded_decoded' := match encode_flux my_instr_liste with
                                      | Some lol => decode_flux_decoup lol
                                      | None => None
                                            end.
Compute my_instr_list_encoded_decoded'.

Definition my_instr_list_encoded_decoded := match encode_flux_b my_instr_liste with
                                      | Some lol => decode_flux lol
                                      | None => None
                                             end.
Compute my_instr_list_encoded_decoded.
(* it seem's to work *)


Require Export Adjoint.UnitCounit Adjoint.UnitCounitCoercions UniversalProperties Adjoint.Duals Comma.Duals.
Require Import Common.

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

Local Open Scope morphism_scope.

Section AdjunctionUniversal.
  Section initial.
    Variable C : PreCategory.
    Variable D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.
    Variable A : F ⊣ G.
    Variable Y : C.

    Definition InitialMorphismOfAdjunction
    : Object (Y ↓ G)
      := @Build_CommaCategory_Object
           TerminalCategory D C
           (! Y) G
           tt
           (F Y)
           ((Adjunction_Unit A) Y).

    Definition IsInitialMorphismOfAdjunction
    : IsInitialMorphism InitialMorphismOfAdjunction.
    Proof.
      unfold InitialMorphismOfAdjunction.
      pose (projT1 (A : AdjunctionCounit F G)) as ε.
      pose (projT1 (A : AdjunctionUnit F G)) as η.
      rename η into i, Y into c, G into R, F into L.
      apply Build_IsInitialMorphism.
      intros d f.
      exists ((Adjunction_Counit A) d ∘ L ₁ f).
      abstract (
          repeat match goal with
                   | _ => intro
                   | _ => split
                   | _ => progress simpl in *
                   | _ => solve [ auto with morphism
                                | apply symmetry; auto with morphism ]
                   | _ => progress rewrite ?FCompositionOf
                   | _ => progress subst
                   | [ |- appcontext[ComponentsOf ?T] ]
                     => simpl_do_clear try_associativity_quick_rewrite_rev (Commutes T);
                   first [ try_associativity_quick_rewrite Adjunction_UnitCounitEquation2
                         | try_associativity_quick_rewrite Adjunction_UnitCounitEquation1 ]
                   | [ |- appcontext[ComponentsOf ?T] ]
                     => simpl_do_clear try_associativity_quick_rewrite (Commutes T);
                   first [ try_associativity_quick_rewrite Adjunction_UnitCounitEquation2
                         | try_associativity_quick_rewrite Adjunction_UnitCounitEquation1 ]
                 end
        ).
    Defined.
  End initial.

  Global Arguments InitialMorphismOfAdjunction [C D F G] A Y.
  Global Arguments IsInitialMorphismOfAdjunction [C D F G] A Y _.

  Section terminal.
    Variable C : PreCategory.
    Variable D : PreCategory.
    Variable F : Functor C D.
    Variable G : Functor D C.
    Variable A : F ⊣ G.
    Variable X : D.

    Definition TerminalMorphismOfAdjunction
    : Object (F ↓ X)
      := Eval simpl in
          CommaDualFunctor_inv
            F (! X)
            (InitialMorphismOfAdjunction A^op X).

    Definition IsTerminalMorphismOfAdjunction
    : IsTerminalMorphism TerminalMorphismOfAdjunction
      := IsInitialMorphismOfAdjunction A^op X.
  End terminal.

  Global Arguments TerminalMorphismOfAdjunction [C D F G] A X.
  Global Arguments IsTerminalMorphismOfAdjunction [C D F G] A X _.
End AdjunctionUniversal.

Section AdjunctionFromUniversal.
  Section initial.
    Variable C : PreCategory.
    Variable D : PreCategory.

    Variable G : Functor D C.
    Context `(HM : forall Y, @IsInitialMorphism _ _ Y G (M Y)).

    Definition AdjointFunctorOfInitialMorphism : Functor C D.
    Proof.
      refine (Build_Functor
                C D
                (fun Y
                 => let ηY := IsInitialMorphism_Morphism (@HM Y) in
                    let F0Y := IsInitialMorphism_Object (@HM Y) in
                    F0Y)
                (fun Y0 Y1 f
                 => let ηY1 := IsInitialMorphism_Morphism (@HM Y1) in
                    (IsInitialProperty_Morphism (@HM Y0) _ (ηY1 ∘ f)))
                _
                _);
      abstract (
          simpl in *;
          repeat intro;
          repeat match goal with
                   | [ |- context[@HM ?x] ]
                     => generalize (@HM x); intro
                 end;
          clear HM;
          intro_universal_properties;
          unfold unique in *;
            split_and;
          apply_hyp';
          rewrite ?FCompositionOf, ?FIdentityOf, ?LeftIdentity, ?RightIdentity;
          try reflexivity;
          try_associativity_quick ltac:(rewrite_hyp);
          try_associativity_quick ltac:(f_ap)
        ).
    Defined.

    Definition AdjunctionOfInitialMorphism
    : AdjointFunctorOfInitialMorphism ⊣ G.
    Proof.
      refine (_ : AdjunctionUnit AdjointFunctorOfInitialMorphism G).
      exists (Build_NaturalTransformation
                (IdentityFunctor C)
                (G ∘ AdjointFunctorOfInitialMorphism)
                (fun x => IsInitialMorphism_Morphism (@HM x))
                (fun s d m => symmetry _ _ (fst (InitialProperty (@HM s) _ _)))).
      simpl.
      exact (fun c d f => (IsInitialProperty_Morphism (@HM c) d f
                           ; InitialProperty (@HM c) d f)).
    Defined.
  End initial.

  Section terminal.
    Variable C : PreCategory.
    Variable D : PreCategory.

    Variable F : Functor C D.
    Context `(HM : forall X, @IsTerminalMorphism _ _ F X (M X)).

    Definition AdjointFunctorOfTerminalMorphism : Functor D C
      := (@AdjointFunctorOfInitialMorphism
            (D^op) (C^op)
            (F^op)
            (fun x => CommaDualFunctor F (FunctorFromTerminal D x) (M x)) HM)^op'.

    Definition AdjunctionOfTerminalMorphism
    : F ⊣ AdjointFunctorOfTerminalMorphism
      := ((@AdjunctionOfInitialMorphism
             (D^op) (C^op)
             (F^op)
             (fun x => CommaDualFunctor F (FunctorFromTerminal D x) (M x)) HM)^op'R)%adjunction.
  End terminal.
End AdjunctionFromUniversal.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e382m105_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition carry :
  { carry : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (carry a) = (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_carry ().
  Show Ltac Profile.
Time Defined.

Print Assumptions carry.