(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Definition synth (y : lst) : lst := append Nil (append y Nil).


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 A B C T P : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B T /\ (wd_ A T /\ (wd_ T P /\ (col_ A B P /\ (col_ A B C /\ col_ A C T))))))) -> col_ A B T)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Maps.
Require Import Coq.Logic.FunctionalExtensionality.

Lemma symmetry_neq : forall {T : Type} (P Q : T), P <> Q <-> Q <> P.
Proof.
  intros P Q. split; intros Hneq Heq; subst; apply Hneq; reflexivity.
Qed.

Lemma update_split_shadow: forall T (Gamma : partial_map T) x y a b c,
        update (update (update Gamma x a) y b) x c =
        update (update Gamma y b) x c.
Proof with auto.
  intros T Gamma x y a b c.
  apply functional_extensionality. intros z.
  unfold update. unfold t_update.
  destruct (beq_idP x z); subst...
Qed.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.
Require Import AutosubstSsr ARS Context.
Require Import Program.Equality.

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

Require Import astCast.
Require Import smallstepCast.
Require Import confluenceCast.
Require Import typingCast.

Lemma ty_evar Gamma (A : term) (x : var) :
  A = Gamma `_ x -> x < size Gamma -> [ Gamma |- Var x :- A ].
Proof. move=> -> sz. exact: ty_var. Qed.

Lemma ty_eapp Gamma (A B C s t : term) :
  C = B.[t/] ->
  [ Gamma |- s :- Pi A B ] ->
  [ Gamma |- t :- A ] ->
  [ Gamma |- App s t :- C ].
Proof. move=> ->. exact: ty_app. Qed.

Lemma ty_tt_wf Gamma :
  [ Gamma |- TT ].
Proof. exact: ty_tt. Qed.

Lemma ty_pi_wf Gamma A B :
  [ Gamma |- A ] ->
  [ A :: Gamma |- B ] ->
  [ Gamma |- Pi A B ].
Proof. exact: ty_pi. Qed.

Lemma ty_renaming xi Gamma Delta s A :
  [ Gamma |- s :- A ] ->
  (forall x, x < size Gamma -> xi x < size Delta) ->
  (forall x, x < size Gamma -> (Gamma`_x).[ren xi] = Delta`_(xi x)) ->
  [ Delta |- s.[ren xi] :- A.[ren xi] ].
Proof with eauto using has_type.
  move=> tp. elim: tp xi Delta => { Gamma s A } /=...
  - move=> Gamma x si xi Delta subctx ->...
  - move=> Gamma A B _ ih1 _ ih2 xi Delta subctx eqn.
    apply: ty_pi...
    asimpl.
    apply: ih2.
    + by move=> [//| x /subctx].
    + by move=> [_|x /eqn/=<-]; fold_all; autosubst.
  - move=> Gamma A B s _ ih1 _ ih2 xi Delta subctx eqn.
    apply ty_fun. by apply ih1. fold_all; asimpl.
    replace (B.[ren (1 .: xi >>> (+2))]) with
      (B.[ren (+1)].[ren (0 .: 1 .: xi >>> (+2))]) by asimpl => //.
    apply ih2.
    + move=> [//|]. by move => [//|x /subctx].
    + move=> [|]; fold_all. autosubst.
      move=> [|n /eqn/=<-]; fold_all; autosubst.
  - move=> Gamma A B s t _ ih1 _ ih2 xi Delta subctx eqn //=.
    apply: (@ty_eapp _ A.[ren xi] B.[up (ren xi)]); fold_all.
    + autosubst.
    + exact: ih1.
    + exact: ih2.
  - move=> Gamma A B s eq _ ih xi Delta subctx eqn.
    apply: (@ty_conv _ A.[ren xi] B.[ren xi]).
    + exact: conv_subst.
    + exact: ih.
Qed.

Lemma weakening Gamma s A B :
  [ Gamma |- s :- A ] -> [ B :: Gamma |- s.[ren (+1)] :- A.[ren (+1)] ].
Proof. move=> /ty_renaming. exact. Qed.

Lemma eweakening Gamma s s' A A' B :
  s' = s.[ren (+1)] -> A' = A.[ren (+1)] ->
  [ Gamma |- s :- A ] -> [ B :: Gamma |- s' :- A' ].
Proof. move=>->->. exact: weakening. Qed.

Lemma ty_ok Gamma :
  [ Gamma |- ] -> forall x, x < size Gamma -> [ Gamma |- Gamma`_x ].
Proof.
  elim=> // {Gamma} Gamma A tp _ ih [_|x /ih {tp} tp];
  exact: weakening tp.
Qed.

Lemma sty_up sigma Gamma Delta A :
  [ Delta |- sigma -| Gamma ] ->
  [ A.[sigma] :: Delta |- up sigma -| A :: Gamma ].
Proof.
  move=> stp [_//|x /stp tp] /=. apply: ty_evar => //=. autosubst.
  apply: eweakening tp; autosubst.
Qed.

Lemma ty_subst sigma Gamma Delta s A :
  [ Delta |- sigma -| Gamma ] ->
  [ Gamma |- s :- A ] ->
  [ Delta |- s.[sigma] :- A.[sigma] ].
Proof with eauto using has_type.
  move=> stp tp.
  elim: tp sigma Delta stp => {Gamma s A} /=.
  - move=> Gamma sigma Delta stp => //...
  - move=> Gamma x sz sigma Delta stp.
    exact: stp.
  - move=> Gamma A B _ ih1 _ ih2 sigma Delta stp.
    fold_all.
    apply: ty_pi.
    + exact: ih1.
    + apply ih2.
      exact: sty_up.
  - move=> Gamma A B s _ ih1 _ ih2 sigma Delta stp.
    fold_all.
    apply: ty_fun.
    + by eapply ih1.
    + replace (B.[up sigma].[ren (+1)]) with
        (B.[ren (+1)].[upn 2 sigma]) by asimpl => //.
      apply: ih2 => x si.
      rewrite <- fold_up_up.
      replace ((Pi A.[sigma] B.[up sigma]).[ren (+1)])
        with ((Pi A.[ren (+1)] B.[up (ren (+1))]).[up sigma])
          by asimpl => //.
      apply: sty_up => // => {x si} x si.
      exact: sty_up.
  - move=> Gamma A B s t _ ih1 _ ih2 sigma Delta stp.
    apply: (@ty_eapp _ A.[sigma] B.[up sigma]).
    autosubst.
    + exact: ih1.
    + exact: ih2.
  - move=> Gamma A A' s o _ ih1 _ ih2 _ ih3 sigma Delta stp.
    apply: ty_cast.
    exact: ih1.
    exact: ih2.
    exact: ih3.
  - move=> Gamma A B s e _ ih1 sigma Delta stp.
    apply: (@ty_conv _ A.[sigma] B.[sigma]).
    + exact: conv_subst.
    + exact: ih1.
Qed.

Lemma ty_cut Gamma s t A B :
  [ A :: Gamma |- s :- B ] -> [ Gamma |- t :- A ] ->
  [ Gamma |- s.[t/] :- B.[t/] ].
Proof.
  move=> /ty_subst h tp.
  apply: h => -[_|x leq]; asimpl => //.
  exact: ty_var.
Qed.

Lemma ty_ctx_conv1 Gamma s A B C :
  [ A :: Gamma |- s :- C ] ->
  B === A ->
  [ B :: Gamma |- s :- C ].
Proof.
  move=> tp conv.
  cut ([ B :: Gamma |- s.[ids] :- C.[ids] ]). autosubst.
  apply: ty_subst tp. move=> [_|x //=]. asimpl. eapply ty_conv.
  apply: conv_subst conv.
  eapply ty_var => //.
  move=> le. asimpl. exact: ty_var.
Qed.

Lemma ty_ctx_conv2 Gamma s A1 A2 B1 B2 C :
  [ A1 :: B1 :: Gamma |- s :- C ] ->
  A2 === A1 ->
  B2 === B1 ->
  [ Gamma |- B1 :- TT ] ->
  [ B1 :: Gamma |- A1 :- TT ] ->
  [ A2 :: B2 :: Gamma |- s :- C ].
Proof.
  move=> tp1 conv1 conv2 tp2 tp3.
  cut ([ A2 :: B2 :: Gamma |- s.[ids] :- C.[ids] ]).
  autosubst.
  apply: ty_subst tp1. move=> [_|[_|x]].
  - asimpl. eapply ty_conv. apply: conv_subst conv1. exact: ty_var.
  - asimpl. eapply ty_conv. apply: conv_subst conv2.
    replace (B2.[ren (+2)])
      with ([:: A2, B2 & Gamma]`_1) by autosubst.
    exact: ty_var.
  - move=> le. asimpl.
    replace (ids x.+2)
      with ((Var x).[ren (+1)].[ren (+1)]) by autosubst.
    replace (Gamma`_ x.[ren (+2)])
      with ((Gamma`_ x).[ren (+1)].[ren (+1)]) by autosubst.
    apply weakening.
    apply weakening.
    exact: ty_var.
Qed.

Lemma ty_pi_inv Gamma A B :
  [ Gamma |- Pi A B :- TT ] ->
  [ Gamma |- A :- TT ] /\ [ A :: Gamma |- B :- TT ].
Proof.
  move e:(Pi A B) => s tp. elim: tp A B e => //{Gamma s}.
  - move=> Gamma A B tp1 _ tp2 _ A' B' [->->] => //.
  - move=> Gamma A B s eq tp ih A' B' e.
    subst.
    elim: (ih A' B') => // => tp4 tp5.
    split.
    apply: ty_conv; eauto.
    eauto using has_type.
Qed.

Lemma ty_fun_invX Gamma s A B C :
  [ Gamma |- Fun s :- C ] -> (C === Pi A B) ->
  [ (Pi A B).[ren (+1)] :: A :: Gamma |- s :- B.[ren (+1)] ].
Proof with eauto using conv_subst, conv_sym, conv_pi.
  move e:(Fun s) => t tp eq. elim: tp A B s e eq => // {Gamma C t}.
  - move => Gamma A B s tp1 ih1 tp2 ih2 A' B' s' [->].
    move=> /inj_pi[e1 e2].
    apply: ty_conv. apply: conv_subst e2.
    apply: (ty_ctx_conv2 tp2)...
    elim: (ty_pi_inv tp1) => //.
    replace (TT) with (TT.[ren (+1)]) by autosubst.
    by apply: weakening.
  - move=> Gamma A B s eq1 tp1 ih A' B' s' e eq2. subst.
    apply: ih => //.
    rewrite <- eq2...
Qed.

Lemma ty_fun_inv Gamma s A B :
  [ Gamma |- Fun s :- Pi A B ] ->
  [ (Pi A B).[ren (+1)] :: A :: Gamma |- s :- B.[ren (+1)] ].
Proof. move=> tp. apply: (ty_fun_invX tp). apply: convR. Qed.

Lemma ty_cast_inv Gamma s A B B' o :
  [ Gamma |- Cast s A B o :- B' ] ->
  [ Gamma |- A ] /\
  [ Gamma |- B ] /\
  [ Gamma |- s :- A ] /\ B === B'.
Proof.
  move=> tp.
  dependent induction tp.
  - firstorder.
    assert ([Gamma |- A] /\
            [Gamma |- B] /\
            [Gamma |- s :- A] /\ B === A0);
    eauto; firstorder.
    apply: conv_trans; eauto.
Qed.

Theorem ps_subject_reduction Gamma s A :
  [ Gamma |- ] ->
  [ Gamma |- s :- A ] ->
  forall t, pstep s t -> [ Gamma |- t :- A ].
Proof with eauto using has_type, context_ok, pstep.
  move=> wf tp. elim: tp wf => {Gamma s A}.
  - move=> Gamma wf t st. inv st...
  - move=> Gamma x si wf t st. inv st...
  - move=> Gamma A B tp1 ih1 tp2 ih2 wf t st. inv st.
    apply: ty_pi. exact: ih1. eapply ty_ctx_conv1.
    + apply: ih2...
    + exact: conv1i.
  - move=> Gamma A B s tp1 ih1 tp2 ih2 wf2 t st. inv st.
    apply: ty_fun.
    + exact: tp1.
    + eapply ih2 => //.
      econstructor.
      replace (TT) with (TT.[ren (+1)]) by autosubst.
      exact: weakening.
      move: tp1 => /ty_pi_inv[tp _].
      econstructor => //.
  - move=> Gamma A B s t tp1 ih1 tp2 ih2 wf t' st. inv st.
    + move: H2 => /pstep_fun.
      move: (wf) => /ih1 h => {tp1 ih1} /h tp1.
      move: (tp1) => /ty_fun_inv.
      move: (wf) (H4) => /ih2 h => {tp2 ih2} /h tp2 tp3.
      move: (tp1) => /weakening h1.
      move: tp3 => /ty_cut h2.
      move: (h2 _ (h1 A)) => {h1 h2} => h.
      move: h => /ty_cut h.
      move: (h _ tp2) => {h}. asimpl.
      apply: ty_conv.
      apply: conv_beta; eauto.
      exact: conv1i.
    + have: (pstep
        (Cast trm (Pi aty1 bodty1) (Pi aty bodty) o)
        (Cast trm' (Pi aty1' bodty1') (Pi aty' bodty') o'))...
      move=> ps.
      specialize (ih1 wf _ ps) => { ps }.
      specialize (ih2 wf _ H3).
      move: ih1 => /ty_cast_inv [tp3 [tp4 [tp5 eq]]].
      move: eq => /inj_pi [eq1 eq2].
      have: ([ Gamma |- ac :- aty1' ]).
      subst ac.
      apply: ty_cast.
      apply ty_pi_inv in tp4; firstorder.
      apply ty_pi_inv in tp3; firstorder.
      apply: ty_conv.
      apply: conv_sym.
      apply: eq1.
      apply: ih2.
      move=> tp6.
      have: (bodty'.[a'/] === B.[t/]).
      apply: conv_beta...
      apply: (conv1i H3).
      move=> eq3.
      apply: ty_conv...
      apply: ty_cast...
      apply ty_pi_inv in tp3; firstorder.
      replace (TT) with (TT.[ac/]) by autosubst.
      apply: ty_cut...
      apply ty_pi_inv in tp4; firstorder.
      replace (TT) with (TT.[a'/]) by autosubst.
      apply: ty_cut...
      apply: ty_conv.
      apply: conv_sym...
      eauto.
    + pose proof (conv1i H3).
      have: (B.[a'/] === B.[t/]) by apply conv_beta.
      move=> h.
      apply: ty_conv.
      apply: h.
      apply: ty_app.
      apply: ih1 => //.
      apply: ih2 => //.
  - move=> Gamma A s t p tp1 ih1 tp2 ih2 tp3 ih3 wf t0 st. inv st.
    + apply: ih3 => //.
    + apply: ty_conv.
      apply: (conv1i H6).
      apply: ty_cast.
      apply: ih1...
      apply: ih2...
      apply: ty_conv.
      exact: (conv_sym (conv1i H5)).
      apply: ih3...
  - move=> Gamma A B s eq tp ih wf t st.
    apply (ty_conv eq).
    apply: ih => //.
Qed.

Theorem step_subject_reduction Gamma s A :
  [ Gamma |- ] -> [ Gamma |- s :- A ] ->
  forall t, step s t -> [ Gamma |- t :- A ].
Proof.
  move=> wf tp t /step_pstep ps.
  apply: ps_subject_reduction; eauto.
Qed.

Theorem star_step_subject_reduction s t :
  star step s t ->
  forall Gamma A,
    [ Gamma |- ] ->
    [ Gamma |- s :- A ] ->
    [ Gamma |- t :- A ].
Proof.
  move=> ss.
  dependent induction ss; intros; eauto.
  specialize (IHss _ _ H0 H1).
  apply: step_subject_reduction.
  apply: H0.
  apply: IHss.
  apply: H.
Qed.

(* well typed terms don't get stuck without error *)

Lemma ty_fun_tt' Gamma s t :
  [ Gamma |- Fun s :- t ] -> t === TT -> False.
Proof.
  move=> tp.
  dependent induction tp.
  - move=> eq.
    pose proof (@conv_pi_tt A B) => //=.
  - move=> eq.
    assert (A === TT).
    rewrite H; eauto.
    eauto.
Qed.

Lemma ty_fun_tt Gamma s :
  ~ [ Gamma |- Fun s ].
Proof.
  unfold not=> tp.
  apply: ty_fun_tt'; eauto.
Qed.

Lemma tysyntax_tt :
  ~ (~ tysyntax TT).
Proof with eauto using tysyntax.
  unfold not...
Qed.

Lemma tysyntax_pi A B :
  ~ (~ tysyntax (Pi A B)).
Proof with eauto using tysyntax.
  unfold not...
Qed.

Lemma canonical_form_pi s P :
  [ [::] |- Fun s :- P ] -> (exists A B, P === Pi A B).
Proof with eauto using value, tysyntax.
  move=> tp.
  dependent induction tp...
  assert (exists A' B', A === Pi A' B').
  apply: IHtp...
  firstorder.
  exists x.
  exists x0.
  rewrite <- H...
Qed.

Lemma canonical_form_fun s P :
  [ [::] |- s :- P ] -> value s ->
  forall A B, P === Pi A B ->
  (exists s', s = Fun s') \/
  (exists s' u t o,
    s = Cast s' u t o /\
    t === (Pi A B) /\
    value u /\
    value s').
Proof with eauto using value, tysyntax.
  move=> tp.
  dependent induction tp...
  - move=> v A B eq.
    apply conv_sym in eq.
    apply conv_pi_tt in eq => //.
  - move=> v A B eq. inv v.
  - move=> v A0 B0 eq.
    apply conv_sym in eq.
    apply conv_pi_tt in eq => //.
  - move=> v A0 B0 eq. inv v.
  - move=> v A0 B eq.
    right.
    inv v.
    exists s.
    exists A'.
    exists A.
    exists o.
    firstorder.
  - move=> v A0 B0 eq2.
    apply: IHtp => //.
    rewrite <- eq2...
Qed.

Lemma canonical_form_ty t tt :
  value t ->
  [ [::] |- t :- tt ] ->
  tt === TT ->
  TT = t \/
  (exists A B, Pi A B = t ) \/
  (exists o, blame o t).
Proof with eauto using tysyntax, value, has_type, blame.
  intros.
  dependent induction H...
  assert ([[::] |- Fun b ])...
  apply ty_fun_tt in H => //.
  right. right.
  move: H3 => /ty_cast_inv [ h1 [ h2 [ h3 h4 ] ] ].
  assert ([[::] |- u :- tt ]).
  apply: ty_conv.
  apply: conv_sym.
  apply: H4.
  apply: h1.
  specialize (IHvalue3 H3 H4).
  move: IHvalue3 => [ h5 | [ h6 | h7 ] ]; subst.
  assert ([[::] |- t :- tt]).
  apply: ty_conv.
  apply: conv_sym.
  apply: H4.
  apply: h2.
  specialize (IHvalue2 H5 H4).
  move: IHvalue2 => [ h8 | [ h9 | h10 ] ]; subst.
  assert ([[::] |- e :- tt]).
  apply: ty_conv.
  apply: conv_sym.
  apply H4.
  apply h3.
  specialize (IHvalue1 H6 H4).
  move: IHvalue1 => [ h5 | [ h6 | h7 ] ]; subst.
  apply tysyntax_tt in H => //.
  move: h6 => [ h7 [ h8 h9 ] ]; subst.
  apply tysyntax_pi in H => //.
  move: h7 => [ o' b ].
  exists o'...
  assert ([[::] |- e :- tt]).
  apply: ty_conv.
  apply: conv_sym.
  apply H4.
  apply h3.
  specialize (IHvalue1 H6 H4).
  move: IHvalue1 => [ h5 | [ h6 | h7 ] ]; subst.
  move: h9 => [ A [ B e ] ]; subst.
  apply tysyntax_tt in H => //.
  move: h9 => [ A [ B e' ] ]; subst.
  exists o...
  move: h7 => [ o' b ].
  exists o'...
  move: h10 => [ o' b ].
  exists o'...
  move: h6 => [ A [ B h7 ] ]; subst.
  assert ([[::] |- t :- tt]).
  apply: ty_conv.
  apply: conv_sym.
  apply: H4.
  apply: h2.
  specialize (IHvalue2 H5 H4).
  move: IHvalue2 => [ h5 | [ h6 | h7 ] ]; subst.
  exists o...
  move: h6 => [ A' [ B' e' ]]; subst.
  assert (Pi A' B' === TT).
  apply: conv_trans.
  apply: h4.
  apply: H4.
  apply conv_pi_tt in H6 => //.
  move: h7 => [ o' b ].
  exists o'...
  move: h7 => [ o' b ].
  exists o'...
Qed.

Theorem progress s t :
  [ [::] |- s :- t ] ->
  (value s) \/ (exists s', step s s') \/ (exists o, blame o s).
Proof with eauto using value, step, blame.
  move=> tp.
  dependent induction tp...
  - inv H.
  - firstorder...
    pose proof (canonical_form_fun tp1 H0 (conv_refl _)).
    case: H1 => [h1 | h2].
    + firstorder...
      right. left.
      exists (x.[f, a/]).
      subst...
    + firstorder.
      subst.
      inv H0 => { H11 }.
      apply ty_cast_inv in tp1; firstorder; subst.
      apply canonical_form_ty in H1...
      apply canonical_form_ty in H0...
      move: H1 => [ h1 | [ h2 | h3 ] ]; subst.
      apply conv_sym in H6.
      apply conv_pi_tt in H6 => //.
      move: h2 => [ A' [ B' e ] ]; subst.
      move: H0 => [ h1 | [ h2 | h3 ] ]; subst.
      right. right...
      move: h2 => [ A0 [ B0 e ] ]; subst.
      right. left...
      right. right.
      move: h3 => [ o b ]...
      move: H0 => [ h4 | [ h5 | h6 ] ]; subst.
      right. right.
      move: h3 => [ o b ]...
      right. right.
      move: h3 => [ o b ]...
      right. right.
      move: h3 => [ o b ]...
  - firstorder...
    apply canonical_form_ty in tp1...
    apply canonical_form_ty in tp2...
    firstorder; subst...
    eapply canonical_form_fun in tp3...
    firstorder; subst...
    left. econstructor...
    move=> h. inv h.
    left. econstructor...
    move=> h. inv h.
Qed.

Theorem weak_type_soundnes s s' :
  star step s s' ->
  forall t, [ [::] |- s :- t ] -> Stuck s' -> exists o, blame o s'.
Proof.
  move=> ss.
  dependent induction ss; intros.
  inv H0.
  apply progress in H.
  move: H => [ h1 | [ h2 | h3 ] ]; eauto.
  contradiction.
  contradiction.
  assert ([[::] |- ]).
  constructor.
  pose proof (star_step_subject_reduction ss H2 H0).
  pose proof (step_subject_reduction H2 H3 H).
  apply progress in H4.
  inv H1.
  move: H4 => [ h1 | [ h2 | h3 ] ].
  contradiction.
  contradiction.
  apply: h3.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.Extensions.ProofTheory.Stable.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.

Class Corable
      (L: Language)
      {minL: MinimumLanguage L}
      {pL: PropositionalLanguage L}
      {sepconL: SepconLanguage L}
      {wandL: WandLanguage L}
      (Gamma: Provable L) := {
  corable: expr -> Prop;
  corable_pstable: PropositionalStable L Gamma corable;
  corable_sstable: SeparationStable L Gamma corable;
  corable_sabs: SeparationAbsorbStable L Gamma corable
}.

Section Corable.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {ipAX: IntuitionisticPropositionalLogic L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}
        {wandAX: WandAxiomatization L Gamma}
        {CosAX: Corable L Gamma}.

Lemma corable_andp: forall x y, corable x -> corable y -> corable (x && y).
Proof. intros. apply (@andp_stable L _ _ Gamma corable corable_pstable); auto. Qed.

Lemma corable_orp: forall x y, corable x -> corable y -> corable (x || y).
Proof. intros. apply (@orp_stable L _ _ Gamma corable corable_pstable); auto. Qed.

Lemma corable_impp: forall x y, corable x -> corable y -> corable (x --> y).
Proof. intros. apply (@impp_stable L _ _ Gamma corable corable_pstable); auto. Qed.

Lemma corable_iffp: forall x y, corable x -> corable y -> corable (x <--> y).
Proof. intros. apply (@iffp_stable L _ _ Gamma corable corable_pstable); auto. Qed.

Lemma corable_falsep: corable FF.
Proof. apply (@falsep_stable L _ _ Gamma corable corable_pstable); auto. Qed.

Lemma corable_truep: corable TT.
Proof. apply (@truep_stable L _ _ Gamma corable corable_pstable); auto. Qed.

Lemma corable_sepcon: forall x y, corable x -> corable y -> corable (x * y).
Proof. intros. apply (@sepcon_stable L _ _ _ Gamma corable corable_sstable); auto. Qed.

Lemma corable_wand: forall x y, corable x -> corable y -> corable (x -* y).
Proof. intros. apply (@wand_stable L _ _ _ Gamma corable corable_sstable); auto. Qed.

Instance corable_proper_iff: Proper ((fun x y => |-- x <--> y) ==> iff) corable.
Proof. apply (@stable_proper_iffp L _ _ Gamma corable corable_pstable); auto. Qed.

Lemma corable_andp_sepcon1: forall x y z, corable x -> |-- (x && y) * z <--> x && (y * z).
Proof. intros. apply (@stable_andp_sepcon1 L _ _ _ _ Gamma corable corable_sabs); auto. Qed.

Lemma corable_andp_sepcon2: forall x y z, corable y -> |-- (x && y) * z <--> y && (x * z).
Proof.
  intros.
  rewrite andp_comm.
  apply corable_andp_sepcon1; auto.
Qed.

Lemma corable_sepcon_andp1: forall x y z, corable y -> |-- x * (y && z) <--> y && (x * z).
Proof.
  intros.
  rewrite sepcon_comm.
  rewrite (sepcon_comm x z).
  apply corable_andp_sepcon1; auto.
Qed.

Lemma corable_sepcon_andp2: forall x y z, corable z -> |-- x * (y && z) <--> z && (x * y).
Proof.
  intros.
  rewrite andp_comm.
  apply corable_sepcon_andp1; auto.
Qed.

Lemma corable_sepcon_imply_andp: forall x y, corable x -> corable y -> |-- x * y --> x && y.
Proof.
  intros.
  rewrite <- (andp_truep y) at 1.
  rewrite corable_sepcon_andp1 by auto.
  rewrite <- (andp_truep x) at 1.
  rewrite corable_andp_sepcon1 by auto.
  rewrite <- andp_assoc.
  rewrite (andp_comm x y).
  apply andp_elim1.
Qed.

Lemma corable_sepcon_is_andp {ExtsGamma: ExtSeparationLogic L Gamma}: forall x y, corable x -> corable y -> |-- x * y <--> x && y.
Proof.
  intros.
  rewrite <- (andp_truep y) at 1.
  rewrite corable_sepcon_andp1 by auto.
  rewrite <- (andp_truep x) at 1.
  rewrite corable_andp_sepcon1 by auto.
  rewrite <- andp_assoc.
  rewrite (andp_comm x y).
  rewrite provable_truep_sepcon_truep.
  rewrite andp_truep.
  apply provable_iffp_refl.
Qed.

End Corable.

Existing Instance corable_proper_iff.


Require Import Coq.Structures.Equalities Coq.Structures.EqualitiesFacts.
Require Import Coq.Classes.RelationPairs.

Module Make (Opcode Operand : DecidableType) <: DecidableType.
  Include PairDecidableType Opcode Operand.

  Definition opcode (self : t) : Opcode.t :=
    fst self.
  Definition operand (self : t) : Operand.t :=
    snd self.

  Lemma neq_iff (self other : t) : ~ eq self other <-> ~ Opcode.eq (opcode self) (opcode other) \/ ~ Operand.eq (operand self) (operand other).
  Proof.
    firstorder using Opcode.eq_dec, Operand.eq_dec.
  Qed.

  Lemma neq_opcode (self other : t) : ~ Opcode.eq (opcode self) (opcode other) -> ~ eq self other.
  Proof.
    firstorder.
  Qed.

  Lemma neq_operand (self other : t) : ~ Operand.eq (operand self) (operand other) -> ~ eq self other.
  Proof.
    firstorder.
  Qed.

  Lemma neq_eq_opcode (self other : t) : Opcode.eq (opcode self) (opcode other) -> ~ eq self other <-> ~ Operand.eq (operand self) (operand other).
  Proof.
    firstorder.
  Defined.

  Lemma neq_eq_operand (self other : t) : Operand.eq (operand self) (operand other) -> ~ eq self other <-> ~ Opcode.eq (opcode self) (opcode other).
  Proof.
    firstorder.
  Defined.

  Lemma eq_opcode (self other : t) : Opcode.eq (opcode self) (opcode other) -> eq self other <-> Operand.eq (operand self) (operand other).
  Proof.
    firstorder.
  Defined.

  Lemma eq_operand (self other : t) : Operand.eq (operand self) (operand other) -> eq self other <-> Opcode.eq (opcode self) (opcode other).
  Proof.
    firstorder.
  Defined.
End Make.


From CoqAlgs Require Import Base.

Module Type Queue.

Parameter Queue : Type -> Type.

Parameter empty :
  forall {A : Type}, Queue A.

Parameter isEmpty :
  forall {A : Type}, Queue A -> bool.

Parameter snoc :
  forall {A : Type}, A -> Queue A -> Queue A.

Parameter head :
  forall {A : Type}, Queue A -> option A.

Parameter tail :
  forall {A : Type}, Queue A -> option (Queue A).

(* Properties of [isEmpty]. *)
Parameter isEmpty_empty :
  forall A : Type, isEmpty (@empty A) = true.

Parameter isEmpty_snoc :
  forall (A : Type) (x : A) (q : Queue A),
    isEmpty (snoc x q) = false.

Parameter isEmpty_head_true :
  forall (A : Type) (q : Queue A),
    isEmpty q = true <-> head q = None.

Parameter isEmpty_head_false :
  forall (A : Type) (q : Queue A),
    isEmpty q = false <-> exists h : A, head q = Some h.

Parameter isEmpty_tail_false :
  forall (A : Type) (q : Queue A),
    isEmpty q = false <-> exists q' : Queue A, tail q = Some q'.

Parameter isEmpty_tail_true :
  forall (A : Type) (q : Queue A),
    isEmpty q = true <-> tail q = None.

(* Properties of [head]. *)
Parameter head_empty :
  forall A : Type, head (@empty A) = None.

Parameter head_singl :
  forall (A : Type) (x : A),
    head (snoc x empty) = Some x.

Parameter head_snoc_false :
  forall (A : Type) (x : A) (q : Queue A),
    isEmpty q = false -> head (snoc x q) = head q.

Parameter head_snoc_true :
  forall (A : Type) (x : A) (q : Queue A),
    isEmpty q = true -> head (snoc x q) = Some x.

(* Properties of tail. *)
Parameter tail_empty :
  forall A : Type, tail (@empty A) = None.

Parameter tail_singl :
  forall (A : Type) (x : A),
    tail (snoc x empty) = Some empty.

#[global] Hint Rewrite isEmpty_empty isEmpty_snoc head_empty head_singl
             tail_empty tail_singl : Queue.

End Queue.

(* [fmap] and its properties. *)

(*
Parameter fmap :
  forall {A B : Type}, (A -> B) -> Queue A -> Queue B.

Parameter fmap_empty :
  forall (A B : Type) (f : A -> B),
    fmap f (@empty) = @empty B.

Parameter fmap_isEmpty :
  forall (A B : Type) (f : A -> B) (q : Queue A),
    isEmpty (fmap f q) = isEmpty q.

Parameter fmap_snoc :
  forall (A B : Type) (f : A -> B) (x : A) (q : Queue A),
    fmap f (snoc x q) = snoc (f x) (fmap f q).

Parameter fmap_head :
  forall (A B : Type) (f : A -> B) (q : Queue A),
    head (fmap f q) =
    match head q with
        | None => None
        | Some x => Some (f x)
    end.

Parameter fmap_tail :
  forall (A B : Type) (f : A -> B) (q q' : Queue A),
    tail q = Some q' -> tail (fmap f q) = Some (fmap f q').

Parameter fmap_size :
  forall (A B : Type) (f : A -> B) (q : Queue A),
    size (fmap f q) = size q.*)

Module Type SizedQueue (Q : Queue).

Import Q.

Parameter size :
  forall {A : Type}, Queue A -> nat.

Parameter size_empty :
  forall A : Type, size (@empty A) = 0.

Parameter size_snoc :
  forall (A : Type) (x : A) (q : Queue A),
    size (snoc x q) = S (size q).

Parameter size_tail :
  forall (A : Type) (q q' : Queue A),
    tail q = Some q' -> size q' = pred (size q).

Parameter size_isEmpty_true :
  forall (A : Type) (q : Queue A),
    isEmpty q = true <-> size q = 0.

Parameter size_isEmpty_false :
  forall (A : Type) (q : Queue A),
    isEmpty q = false <-> size q <> 0.

End SizedQueue.

Module ConstantSizedQueue_Queue (Q : Queue) : Queue.

Definition Queue (A : Type) := (nat * Q.Queue A)%type.

Definition empty {A : Type} : Queue A := (0, Q.empty).

Definition isEmpty {A : Type} (q : Queue A) : bool :=
  Q.isEmpty (snd q).

Definition snoc {A : Type} (x : A) (q : Queue A) : Queue A :=
  let '(n, q') := q in (S n, Q.snoc x q').

Definition head {A : Type} (q : Queue A) : option A :=
  Q.head (snd q).

Definition tail {A : Type} (q : Queue A) : option (Queue A) :=
  let '(n, q') := q in
match Q.tail q' with
    | None => None
    | Some q'' => Some (pred n, q'')
end.

Ltac sized := repeat
match goal with
    | |- forall q : Queue _, _ => destruct q
    | |- forall _, _ => intro
end;
  compute; autorewrite with Queue; try reflexivity.

Lemma isEmpty_empty : forall A : Type, isEmpty (@empty A) = true.
Proof. sized. Qed.

Lemma isEmpty_snoc :
  forall (A : Type) (x : A) (q : Queue A), isEmpty (snoc x q) = false.
Proof. sized. Qed.

Lemma isEmpty_head_true :
  forall (A : Type) (q : Queue A), isEmpty q = true <-> head q = None.
Proof.
  sized. rewrite Q.isEmpty_head_true. split; trivial.
Qed.

Lemma isEmpty_head_false :
  forall (A : Type) (q : Queue A),
    isEmpty q = false <-> exists h : A, head q = Some h.
Proof.
  sized. rewrite Q.isEmpty_head_false. split; trivial.
Qed.

Lemma isEmpty_tail_false :
  forall (A : Type) (q : Queue A),
    isEmpty q = false <-> (exists q' : Queue A, tail q = Some q').
Proof.
  sized. rewrite Q.isEmpty_tail_false. firstorder.
    rewrite H. eexists. reflexivity.
    destruct (Q.tail q) eqn: Heq.
      eexists. reflexivity.
      inv H.
Qed.

Lemma isEmpty_tail_true :
  forall (A : Type) (q : Queue A), isEmpty q = true <-> tail q = None.
Proof.
  sized. rewrite Q.isEmpty_tail_true. firstorder.
    rewrite H. reflexivity.
    destruct (Q.tail q) eqn: Heq.
      inv H.
      reflexivity.
Qed.

Lemma head_empty :
  forall A : Type, head (@empty A) = None.
Proof. sized. Qed.

Lemma head_singl :
  forall (A : Type) (x : A), head (snoc x empty) = Some x.
Proof. sized. Qed.

Lemma head_snoc_false :
  forall (A : Type) (x : A) (q : Queue A),
    isEmpty q = false -> head (snoc x q) = head q.
Proof.
  sized. rewrite Q.head_snoc_false.
    reflexivity.
    compute in H. assumption.
Qed.

Lemma head_snoc_true :
  forall (A : Type) (x : A) (q : Queue A),
    isEmpty q = true -> head (snoc x q) = Some x.
Proof.
  sized. rewrite Q.head_snoc_true.
    reflexivity.
    compute in H. assumption.
Qed.

Lemma tail_empty :
  forall A : Type, tail (@empty A) = None.
Proof. sized. Qed.

Lemma tail_singl :
  forall (A : Type) (x : A), tail (snoc x empty) = Some empty.
Proof. sized. Qed.

End ConstantSizedQueue_Queue.


Require Import ZArith.
(*Require Import Coq.Strings.String.*)
Require Import List. Import ListNotations.
Require Import NPeano.

From QuickChick Require Import QuickChick.

Require Import TestingCommon. Import Mem.
Require Import Indist.
Require Import Generation.

Local Open Scope nat.

(* CH: old stuff about sets of prins
Powerset returns the set as its first element, so ignore that
Definition shrinkLabel l :=
    match powerset (Zset.elements l) with
      | [[]] => nil
      | _::t => map lab_of_list t
      | _    => nil
    end.
*)
Definition shrinkLabel l :=
  match l with
  | L       => []
  | M1 | M2 => [L]
  | H       => [L;M1;M2]
  end.

Definition shrinkBinop (b : BinOpT) : list BinOpT := nil.
Definition shrinkInstr (i : @Instr Label) : list (@Instr Label) :=
  match i with
    | Nop => nil
    | PutLab l r =>
      List.map (fun l' => PutLab l' r) (shrinkLabel l) ++ [Nop]
    | _ => [Nop]
  end.

Definition shrinkPointer (p : Pointer) : list Pointer :=
  let '(Ptr mf i) := p in
  List.map (Ptr mf) (shrink i).

Definition shrinkValue (v : Value) : list Value :=
  match v with
    | Vint i => List.map Vint (shrink i)
    | Vptr p => Vint Z0 :: List.map Vptr (shrinkPointer p)
    | Vlab l => Vint Z0 :: List.map Vlab (shrinkLabel l)
  end.

Definition shrinkAtom (a : Atom) : list Atom :=
  let '(Atm val lab) := a in
  List.map (flip Atm lab) (shrinkValue val)
  ++  List.map (Atm val) (shrinkLabel lab).

Fixpoint noopShrink (n : nat) (l : Label) (l1 l2 : list (@Instr Label))
: list (@Variation (list (@Instr Label))) :=
  match n with
    | S n' =>
      match List.nth n' l1 Nop, List.nth n' l2 Nop with
        | Nop, Nop =>
          noopShrink n' l l1 l2
        | _, _ =>
          match update_list_Z l1 (Z.of_nat n') Nop, update_list_Z l2 (Z.of_nat n') Nop with
            | Some l1', Some l2' => cons (Var l l1' l2')
                                         (noopShrink n' l l1 l2)
            | _, _ => noopShrink n' l l1 l2
          end
      end
    | _ => nil
  end.

Fixpoint noopRemove (l : Label) (l1 l2 : list (@Instr Label))
         (acc1 acc2 : list (@Instr Label)) :=
  match l1, l2 with
    | Nop :: t1, Nop :: t2 =>
      (Var l (rev_append acc1 t1)) (rev_append acc2 t2)
      :: (noopRemove l t1 t2 (Nop :: acc1) (Nop :: acc2))
    | h1 :: t1, h2 :: t2 =>
      noopRemove l t1 t2 (h1 :: acc1) (h2 :: acc2)
    | _, _ => nil
  end.

Instance shrVVal : ShrinkV Value :=
{|
  shrinkV vv :=
    match vv with
      | Var lab (Vint i) (Vint _) =>
        List.map (fun i => Var lab (Vint i) (Vint i)) (shrink i)
      | Var lab (Vptr p) (Vptr _) =>
        List.map (fun p => Var lab (Vptr p) (Vptr p)) (shrinkPointer p)
      | Var lab (Vlab l) (Vlab _) =>
        List.map (fun l => Var lab (Vlab l) (Vlab l)) (shrinkLabel l)
      | _ => nil
    end
|}.

Definition shrinkVLabeled {A B : Type} (c : B -> Label -> A) (b b' : B)
           (l lab : Label) : list (@Variation A) :=
  flat_map (fun ls =>
    if flows ls lab then
      [Var lab (c b ls) (c b ls);
       Var lab (c b' ls) (c b' ls)]
    else
      [Var lab (c b ls) (c b' ls)]
  ) (shrinkLabel l).

Instance shrVAtom : ShrinkV Atom :=
{|
  shrinkV va :=
    let '(Var lab (Atm v l) (Atm v' l')) := va in
    if flows l lab then
      List.map (fun v => let '(Var _ v1 v2) := v in
                    Var lab (Atm v1 l) (Atm v2 l')) (shrinkV (Var lab v v'))
    else
      let a1s := List.map (fun v1 => Atm v1 l) (shrinkValue v)  in
      let a2s := List.map (fun v2 => Atm v2 l) (shrinkValue v') in
      List.map (fun a => Var lab a (Atm v' l')) a1s ++
      List.map (fun a' => Var lab (Atm v l) a') a2s ++
      concat (List.map (fun a => List.map (fun a' => Var lab a a') a2s) a1s)
    ++ shrinkVLabeled Atm v v' l lab
|}.

Fixpoint shrink_datas (lab : Label) (ds ds' : list Atom) :=
  match ds, ds' with
    | h1 :: t1, h2 :: t2 =>
      Var lab t1 t2 ::
      List.map (fun x => let '(Var _ h1' h2') := x in
                    Var lab (h1':: t1) (h2'::t2)) (shrinkV (Var lab h1 h2))
      ++ List.map (fun x => let '(Var _ t1' t2') := x in
                       Var lab (h1::t1') (h2::t2')) (shrink_datas lab t1 t2)
    | _, _ => nil
  end.

Definition shrinkListAtom := shrinkListAux shrinkAtom.

(* Probably need to revisit this *)
Instance shrVFrame : ShrinkV frame :=
{|
  shrinkV vf :=
    let '(Var obs (Fr lab data1) (Fr lab2 data2)) := vf in
    if isLow lab obs then
      List.map (fun x => let '(Var _ ds1 ds2) := x in
                    Var lab (Fr lab ds1) (Fr lab2 ds2))
          (shrink_datas obs data1 data2)
    else
      List.map (fun data1' => Var lab (Fr lab data1') (Fr lab2 data2))
          (shrinkListAtom data1) ++
      List.map (fun data2' => Var lab (Fr lab data1) (Fr lab2 data2'))
          (shrinkListAtom data2)
|}.

(*
Fixpoint liftFrameMem (mf : mframe) (l : Label) (m1 m2 : mem)
         (lf : list (@Variation Frame)) :=
  match lf with
    | [] => []
    | (Var lab f1' f2') :: t =>
      match update_frame m1 mf f1', update_frame m2 mf f2' with
        | Some m1', Some m2' => (Var lab m1' m2')
                                  :: (liftFrameMem mf l m1 m2 t)
        | _, _ => liftFrameMem mf l m1 m2 t
      end
  end.

Fixpoint shr_v_mem (lim : nat) (mf : mframe) (l : Label) (m1 m2 : mem) :=
  match lim with
    | O => nil
    | S lim' =>
      match load_frame m1 mf, load_frame m2 mf with
        | Some f1, Some f2 =>
          app (liftFrameMem mf l m1 m2 (shrinkV (Var l f1 f2)))
                 (shr_v_mem lim' (Zsucc mf) l m1 m2)
        | _, _ => nil
      end
  end.

Instance shrVMem : ShrinkV mem :=
{|
  shrinkV vm :=
    match vm with
      | Var lab m1 m2 =>
        app (shr_v_mem 42 Z0 lab m1 m2)
            nil
    end
|}.
*)
(* CH: removed this crap
Fixpoint stackLength (s : Stack) :=
  match s with
    | Mty => 0
    | RetCons _ s' => 1 + stackLength s'
  end.

Function shrink_stacks (lab : Label) (sp : Stack * Stack )
         {measure (fun sp => stackLength (fst sp) + stackLength (snd sp)) sp}:=
  (* TODO: Think about shrinking individual stack info *)
  let (s1, s2) := sp in
  match s1, s2 with
    | RetCons h1 t1, RetCons h2 t2 =>
      let '(pc1, _ , _ , _ ) := h1 in
      let '(pc2, _ , _ , _ ) := h2 in
      if flows (pc_lab pc1) lab && flows (pc_lab pc2) lab then
        (* Both are low *)
        flat_map (fun vt => let '(Var lab t1' t2') := vt in
                            [ Var lab (RetCons h1 t1') (RetCons h2 t2') ;
                              Var lab t1' t2' ])
                 (shrink_stacks lab (t1, t2))
      else if flows (pc_lab pc1) lab then
        (* Mach 2 is high *)
        shrink_stacks lab (s1, t2)
      else
        (* Mach 1 is high *)
        shrink_stacks lab (t1, s2)
    | _, _ => nil
  end.
Proof.
intros; unfold fst; unfold snd; unfold stackLength; simpl; omega.
intros; unfold fst; unfold snd; unfold stackLength; simpl; omega.
intros; unfold fst; unfold snd; unfold stackLength; simpl; omega.
Defined.
*)

Instance shrVStack : ShrinkV Stack :=
{|
  shrinkV vs := []
(*
    let '(Var lab s1 s2) := vs in p
    shrink_stacks lab (s1, s2)
*)
|}.

(*
Fixpoint liftMemState (st1 st2 : State) (lm : list (@Variation mem)) :=
  match st1, st2 with
    | St _ p1 s1 regs1 pc1, St _ p2 s2 regs2 pc2 =>
      match lm with
        | nil => nil
        | cons (Var lab m1' m2') t =>
          cons (Var lab (St m1' p1 s1 regs1 pc1) (St m2' p2 s2 regs2 pc2))
               (liftMemState st1 st2 t)
      end
  end.
*)

Fixpoint liftStackState (st1 st2 : State) (ls : list (@Variation Stack)) :=
  match st1, st2 with
    | St im1 m1 _ regs1 pc1, St im2 m2 _ regs2 pc2 =>
      match ls with
        | nil => nil
        | cons (Var lab s1' s2') t =>
          cons (Var lab (St im1 m1 s1' regs1 pc1) (St im2 m2 s2' regs2 pc2))
               (liftStackState st1 st2 t)
      end
  end.

(*
Definition shrinkStateMemory (v : @Variation State) :=
  let '(Var lab st1 st2) := v   in
  let '(St _ m  p  s  regs1 pc ) := st1 in
  let '(St _ m' p' s' regs2 pc') := st2 in
  liftMemState st1 st2 (shrinkV (Var lab m m')).
*)

Definition shrinkStateStack (v : @Variation State) :=
  let '(Var lab st1 st2) := v in
  let '(St _ _ s  _ _) := st1 in
  let '(St _ _ s' _ _) := st2 in
  liftStackState st1 st2 (shrinkV (Var lab s s')).

Definition shrinkState x :=
  (* shrinkStateMemory x ++ *) shrinkStateStack x.

Definition cDecr (lim r : regId) :=
  if (lim <=? r)%Z then (r - 1)%Z else r.

Definition decrRegInstr (r : regId) (i : @Instr Label) :=
  match i with
  | Lab r1 r2 => Lab (cDecr r r1) (cDecr r r2)
  | MLab r1 r2 => MLab (cDecr r r1) (cDecr r r2)
  | PcLab r1 => PcLab (cDecr r r1)
  | BCall r1 r2 r3 => BCall (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | BRet => BRet
  | PutLab l r1 => PutLab l (cDecr r r1)
  | Nop => Nop
  | Put n r1 => Put n (cDecr r r1)
  | BinOp o r1 r2 r3 => BinOp o (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | Jump r1 => Jump (cDecr r r1)
  | BNZ n r1 => BNZ n (cDecr r r1)
  | Load r1 r2 => Load (cDecr r r1) (cDecr r r2)
  | Store r1 r2 => Store (cDecr r r1) (cDecr r r2)
  | Write r1 r2 => Write (cDecr r r1) (cDecr r r2)
  | Alloc r1 r2 r3 => Alloc (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | PSetOff r1 r2 r3 => PSetOff (cDecr r r1) (cDecr r r2) (cDecr r r3)
  | Halt => Halt
  | MSize r1 r2 => MSize (cDecr r r1) (cDecr r r2)
  | PGetOff r1 r2 => PGetOff (cDecr r r1) (cDecr r r2)
  | Mov r1 r2 => Mov (cDecr r r1) (cDecr r r2)
  end.

(* TODO
Fixpoint decrRegInFrames (m : mem) (fs : list mframe) (r : regId) :=
  match fs with
    | []   => m
    | h::t =>
      match load_frame m h with
        | Some (CFR is) =>
          match update_frame m h (CFR (map (decrRegInstr r) is)) with
            | Some m' =>
              decrRegInFrames m' t r
            | _ => decrRegInFrames m t r
          end
        | _ => decrRegInFrames m t r
      end
end.

Definition removeReg (st : State) (r : regId) :=
  let '(St m p s rs pc) := st in
  let rn := Z.to_nat r in
  let rsHd := firstn rn rs in
  let rsTl := skipn (S rn) rs in
  St (decrRegInFrames m (allocated m) r) p s (rsHd ++ rsTl) pc.
*)
Fixpoint shrinkVRegContents (l : Label) (prev prev' rest rest' : regSet)
: list (@Variation regSet) :=
  match rest, rest' with
    | h1 :: t1, h2 :: t2 =>
      let shrunk := shrinkV (Var l h1 h2) in
      List.map (fun v' =>
        let '(Var _ h1' h2') := v' in
        Var l (rev_append prev  (h1'::t1))
              (rev_append prev' (h2'::t2))
      ) shrunk ++ shrinkVRegContents l (h1 :: prev) (h2 :: prev') t1 t2

    | _, _ => nil
  end.

Fixpoint liftRegsState (st1 st2 : State) (ls : list (@Variation regSet)) :=
  match st1, st2 with
    | St im1 m1 s1 _ pc1, St im2 m2 s2 _ pc2 =>
      match ls with
        | nil => nil
        | cons (Var lab regs1' regs2') t =>
          cons (Var lab (St im1 m1 s1 regs1' pc1) (St im2 m2 s2 regs2' pc2))
               (liftRegsState st1 st2 t)
      end
  end.

Definition shrinkVRegs (v : @Variation State) :=
    let '(Var l st st') := v in
    let '(St _ _ _ regs _) := st in
    let '(St _ _ _ regs' _) := st' in
(*    let regsNo := List.length regs - 1 in
    let allRegs := map Z.of_nat (seq 0 regsNo) in
    let sts  := map (removeReg st ) allRegs in
    let sts' := map (removeReg st') allRegs in
    map (fun x : (State * State) =>
           let (st1,st2) := x in Var l st1 st2) (combine sts sts') ++*)
    (liftRegsState st st' (shrinkVRegContents l nil nil regs regs')).

Definition shrinkVState (x : @Variation State) :=
  shrinkState x
(*  ++ concat (map shrinkStateMemory (shrinkStateMemory x))
  ++ concat (map shrinkStateMemory (shrinkStateStack x))
  ++ concat (map shrinkStateStack  (shrinkStateMemory x))*)
  ++ shrinkVRegs x.
(*
Definition shrinkObsVar v :=
    let '(V lab st st' mf fm1 fm2) := v in
    let x := obsVarToVar v in
    map (varToObsVar mf fm1 fm2) (shrinkVState x).
*)


Add LoadPath "..".
Require Import Setoid.
Require Export LibTactics.
Require Export Shared.
Require Export ListLib.
Require Export PermutLib.

Open Scope permut_scope.

Inductive PPermut_Hyb: list ctx_Hyb -> list ctx_Hyb -> Prop :=
| PPermut_Hyb_nil: PPermut_Hyb nil nil
| PPermut_Hyb_skip: forall G G' w Gamma Gamma',
    Gamma *=* Gamma' ->
    PPermut_Hyb G G' ->
    PPermut_Hyb ((w, Gamma)::G) ((w,Gamma')::G')
| PPermut_Hyb_swap: forall G w w' Gamma0 Gamma0' Gamma1 Gamma1',
    Gamma0 *=* Gamma1 ->
    Gamma0' *=* Gamma1' ->
    PPermut_Hyb ((w, Gamma0) :: (w', Gamma0') :: G)
                ((w', Gamma1') :: (w, Gamma1) :: G)
| PPermut_Hyb_trans: forall G G' G'',
    PPermut_Hyb G G' -> PPermut_Hyb G' G'' -> PPermut_Hyb G G''.
Hint Resolve PPermut_Hyb_nil PPermut_Hyb_skip PPermut_Hyb_swap.
Hint Constructors PPermut_Hyb : ppermut_rew.

Notation "G ~=~ G'" := (PPermut_Hyb G G') (at level 70) : permut_scope.

Lemma PPermut_Hyb_reflexive:
  Reflexive PPermut_Hyb.
unfold Reflexive; intros;
induction x; [ | destruct a]; eauto.
Qed.

Lemma PPermut_Hyb_symmetric:
  Symmetric PPermut_Hyb.
unfold Symmetric; intros;
induction H; eauto with ppermut_rew.
  apply PPermut_Hyb_trans with (G':=(w, Gamma')::G); eauto with ppermut_rew;
  apply PPermut_Hyb_skip;
  [ apply permut_sym |
    apply PPermut_Hyb_reflexive];
  auto.
  apply PPermut_Hyb_swap; apply permut_sym; assumption.
Qed.

Lemma PPermut_Hyb_transitive:
  Transitive PPermut_Hyb.
exact PPermut_Hyb_trans.
Qed.
Hint Resolve PPermut_Hyb_reflexive PPermut_Hyb_symmetric.

Theorem PPermut_Hyb'oid: Setoid_Theory _ PPermut_Hyb.
  split.
  exact PPermut_Hyb_reflexive.
  exact PPermut_Hyb_symmetric.
  exact PPermut_Hyb_transitive.
Qed.

Add Setoid (list ctx_Hyb) PPermut_Hyb PPermut_Hyb'oid as PPermut_Hyboid.

Add Morphism (@cons ctx_Hyb) : PPermut_Hyb_cons.
intro y; destruct y; auto.
Qed.
Hint Resolve PPermut_Hyb_cons.

Lemma PPermut_Hyb_app_tail:
forall G G' G0,
  G ~=~ G' ->
  G ++ G0 ~=~ G' ++ G0.
intros; induction H; simpl; rew_app; auto;
econstructor; eauto.
Qed.

Lemma PPermut_Hyb_app_head:
forall G0 G G',
  G ~=~ G' ->
  G0 ++ G ~=~ G0 ++ G'.
intros; induction G0; simpl; rew_app; auto.
Qed.
Hint Resolve PPermut_Hyb_app_tail PPermut_Hyb_app_head.

Add Morphism (@append ctx_Hyb) : PPermut_Hyb_app.
intros; induction H; simpl in *; rew_app; auto.
transitivity ((w, Gamma0) :: (w', Gamma0') :: G ++ y0); auto.
transitivity (G' ++ y0); auto.
Qed.
Hint Resolve PPermut_Hyb_app.

Theorem PPermut_Hyb_app_comm:
forall G1 G2,
  G1 ++ G2 ~=~ G2 ++ G1.
induction G1; intros; simpl; rew_app;
[ auto |
 induction G2]; simpl in *;
[ rewrite app_nil_r; auto |
  destruct a; destruct a0];
transitivity ((v,l) :: (v0, l0) :: G2 ++ G1);
[ constructor; auto; apply IHG1 |
  transitivity ((v0, l0) :: (v, l) :: G2 ++ G1); auto];
rew_app; constructor; auto;
transitivity ((v,l) :: G1 ++ G2); auto.
Qed.
Hint Resolve PPermut_Hyb_app_comm.

(*** Automation **)
(* Based on permutation tactics from tlc's LibListSorted *)

Lemma PPermut_Hyb_get_1 : forall l1 l2,
  PPermut_Hyb (l1 ++ l2) (l1 ++ l2).
auto.
Qed.

Lemma PPermut_Hyb_get_2 : forall l1 l2 l3,
  PPermut_Hyb (l1 ++ l2 ++ l3) (l2 ++ l1 ++ l3).
intros;
assert (l1 ++ l2 ~=~ l2 ++ l1) as H by auto;
transitivity ((l1 ++ l2) ++ l3); [ | rewrite H ]; rew_app; auto.
Qed.

Lemma PPermut_Hyb_get_3 : forall l1 l2 l3 l4,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4) (l2 ++ l3 ++ l1 ++ l4).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_2.
Qed.

Lemma PPermut_Hyb_get_4 : forall l1 l2 l3 l4 l5,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4 ++ l5)
         (l2 ++ l3 ++ l4 ++ l1 ++ l5).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_3.
Qed.

Lemma PPermut_Hyb_get_5 : forall l1 l2 l3 l4 l5 l6,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6)
         (l2 ++ l3 ++ l4 ++ l5 ++ l1 ++ l6).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_4.
Qed.

Lemma PPermut_Hyb_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
  PPermut_Hyb (l1 ++ l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l7)
         (l2 ++ l3 ++ l4 ++ l5 ++ l6 ++ l1 ++ l7).
intros;
do 2 rewrite <- (@app_assoc _ l2); eapply PPermut_Hyb_get_5.
Qed.

Lemma PPermut_Hyb_tactic_setup : forall l1 l2,
  PPermut_Hyb (nil ++ l1 ++ nil) (l2 ++ nil) -> PPermut_Hyb l1 l2.
intros; rew_app in *; auto.
Qed.

Lemma PPermut_Hyb_tactic_keep : forall l1 l2 l3 l4,
  PPermut_Hyb ((l1 ++ l2) ++ l3) l4 ->
  PPermut_Hyb (l1 ++ (l2 ++ l3)) l4.
intros; rew_app in *; auto.
Qed.

Lemma PPermut_Hyb_tactic_simpl : forall l1 l2 l3 l4,
  PPermut_Hyb (l1 ++ l3) l4 ->
  PPermut_Hyb (l1 ++ (l2 ++ l3)) (l2 ++ l4).
intros; rewrite <- H; apply PPermut_Hyb_get_2.
Qed.

Lemma PPermut_Hyb_tactic_trans : forall l1 l2 l3,
  PPermut_Hyb l3 l2 -> PPermut_Hyb l1 l3 -> PPermut_Hyb l1 l2.
intros; eauto with ppermut_rew.
Qed.

Hint Rewrite app_assoc app_nil_l app_nil_r : ppermut_rew.

Ltac PPermut_Hyb_lemma_get n :=
  match nat_from_number n with
  | 1 => constr:(PPermut_Hyb_get_1)
  | 2 => constr:(PPermut_Hyb_get_2)
  | 3 => constr:(PPermut_Hyb_get_3)
  | 4 => constr:(PPermut_Hyb_get_4)
  | 5 => constr:(PPermut_Hyb_get_5)
  end.

Ltac PPermut_Hyb_isolate_cons :=
  do 20 try (* todo : repeat *)
    match goal with |- context [?x::?l] =>
      match l with
      | nil => fail 1
      | _ => rewrite <- (@app_cons_one _ x l)
      end
    end.

Ltac PPermut_Hyb_simpl_prepare :=
   autorewrite with ppermut_rew;
   PPermut_Hyb_isolate_cons;
   autorewrite with ppermut_rew;
   apply PPermut_Hyb_tactic_setup;
   repeat rewrite app_assoc.

Ltac PPermut_Hyb_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l ++ _ => constr:(1)
  | _ ++ l ++ _ => constr:(2)
  | _ ++ _ ++ l ++ _ => constr:(3)
  | _ ++ _ ++ _ ++ l ++ _ => constr:(4)
  | _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(5)
  | _ ++ _ ++ _ ++ _ ++ _ ++ l ++ _ => constr:(6)
  | _ => constr:(0) (* not found *)
  end.

Ltac PPermut_Hyb_simpl_once :=
  match goal with
  | |- PPermut_Hyb (_ ++ nil) _ => fail 1
  | |- PPermut_Hyb (_ ++ (?l ++ _)) ?l' =>
     match PPermut_Hyb_index_of l l' with
     | 0 => apply PPermut_Hyb_tactic_keep
     | ?n => let F := PPermut_Hyb_lemma_get n in
            eapply PPermut_Hyb_tactic_trans;
            [ apply F
            | apply PPermut_Hyb_tactic_simpl ]
     end
  end.

Ltac PPermut_Hyb_simpl :=
  PPermut_Hyb_simpl_prepare;
  repeat PPermut_Hyb_simpl_once;
  autorewrite with ppermut_rew;
  try apply PPermut_Hyb_reflexive;
  auto.

(*** Other lemmas ***)
(* Note:
   Some are covered by PPermut_Hyb_simpl tactic, but we want to use them
   in auto! *)

Lemma PPermut_Hyb_Mem:
forall G G' w X,
  G ~=~ G' ->
  Mem (w, X) G ->
  exists X', X' *=* X /\ Mem (w, X') G'.
intros; generalize dependent X; induction H; intros.
rewrite Mem_nil_eq in H0; contradiction.
rewrite Mem_cons_eq in H1; destruct H1.
inversion H1; subst; exists Gamma'; split; [ symmetry | apply Mem_here]; auto.
apply IHPPermut_Hyb in H1; destruct H1 as (Gamma''); exists Gamma'';
destruct H1; split; auto; rewrite Mem_cons_eq; right; auto.
repeat rewrite Mem_cons_eq in H1; destruct H1.
inversion H1; subst; exists Gamma1; split; [ symmetry | rewrite Mem_cons_eq];
auto; right; apply Mem_here.
destruct H1.
inversion H1; subst; exists Gamma1'; split; [ symmetry | rewrite Mem_cons_eq];
auto.
exists X; split; auto; repeat rewrite Mem_cons_eq; right; right; auto.
apply IHPPermut_Hyb1 in H1; destruct H1 as (X'); destruct H1.
apply IHPPermut_Hyb2 in H2; destruct H2 as (X''); destruct H2;
exists X''; split; auto; transitivity X'; auto.
Qed.

Lemma PPermut_Hyb_nil_impl:
forall L,
  nil ~=~ L -> L = nil.
intros; remember (@nil ctx_Hyb) as L' in H;
induction H; intros;
discriminate || auto.
Qed.

Lemma PPermut_Hyb_nil_contr:
forall L a,
  ~ (PPermut_Hyb nil (a::L)).
induction L; intros; intro;
apply PPermut_Hyb_nil_impl in H; discriminate.
Qed.

Hint Resolve PPermut_Hyb_nil_impl PPermut_Hyb_nil_contr.

(* Based on Sorting/Permutation/Permutation_ind_bis *)
Theorem PPermut_Hyb_ind_bis :
 forall P : list ctx_Hyb -> list ctx_Hyb -> Prop,
   P nil nil ->
   (forall w x y l l', l ~=~ l' -> P l l' ->
     x *=* y -> P ((w,x) :: l) ((w,y) :: l')) ->
   (forall w w' x x' y y' l l', l ~=~ l' -> P l l' -> x *=* x' -> y *=* y' ->
     P ((w', y) :: (w, x) :: l) ((w, x') :: (w', y') :: l')) ->
   (forall l l' l'', l ~=~ l' -> P l l' -> l' ~=~ l'' -> P l' l'' -> P l l'') ->
   forall l l', l ~=~ l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans;
  intros; induction H; auto.
  apply Htrans with ((w', Gamma0')::(w, Gamma0)::G); auto.
    apply Hswap; auto; induction G; auto; destruct a; apply Hskip; auto.
    apply Hskip; auto; apply Hskip; auto; induction G; auto;
    destruct a; apply Hskip; auto.
  eauto.
Qed.

Lemma PPermut_Hyb_app_rev:
forall G G' H H' w a a',
  a *=* a' ->
  G & (w, a) ++ G' ~=~ H & (w, a') ++ H' ->
  G ++ G' ~=~ H ++ H'.
Proof.
  set (P l l' :=
         forall w a a' l1 l2 l3 l4, a *=* a' ->
         l=l1 & (w, a) ++ l2 -> l'=l3 & (w, a') ++l4 -> (l1++l2) ~=~ (l3++l4)).
  cut (forall l l', l ~=~ l' -> P l l').
  intros; apply (H _ _ H2 w a a'); auto.
  intros; apply (PPermut_Hyb_ind_bis P); unfold P; clear P;
    try clear H l l'; simpl; auto.
  (* nil *)
  intros; destruct l1; simpl in *; discriminate.
  (* skip *)
  intros w x y l l' H IH; intros.
  destruct l1; destruct l3; rew_app in *;
  inversion H2; inversion H3; subst; auto.
    rewrite H; PPermut_Hyb_simpl; constructor; [transitivity a |] ; auto;
      symmetry; auto.
    rewrite <- H; PPermut_Hyb_simpl; constructor; auto; transitivity a';
      [ | symmetry]; auto.
  constructor; auto.
  apply (IH w0 a a' l1 l2 l3 l4); rew_app; auto.
  (* swap *)
  intros w w' x x' y y' l l' Hp IH; intros.
  destruct l1; destruct l2; rew_app in *; subst;
  inversion H2; subst; auto; try rewrite Hp; rew_app;
  PPermut_Hyb_simpl; destruct l3; destruct l4; rew_app in *; subst;
  inversion H3; subst; auto.
    constructor; auto; transitivity a'; auto; transitivity a; auto;
    symmetry; auto.
    constructor; auto; destruct l3; rew_app in *; inversion H6; subst; auto;
      PPermut_Hyb_simpl; constructor; auto; transitivity a; auto; symmetry; auto.
    constructor; auto; destruct l3; rew_app in *; inversion H6; subst; auto;
      PPermut_Hyb_simpl; constructor; auto; transitivity a; auto; symmetry; auto.
    constructor; auto; destruct l1; rew_app in *; inversion H6; subst; auto;
      PPermut_Hyb_simpl; rewrite <- Hp; PPermut_Hyb_simpl; constructor; auto;
      transitivity a'; auto; symmetry; auto.
  destruct l1; destruct l3; rew_app in *; inversion H6; inversion H7; subst;
    auto.
      constructor; auto; transitivity a'; auto; transitivity a; auto;
        symmetry; auto.
       apply PPermut_Hyb_nil_impl in Hp; destruct l3; rew_app in *; discriminate.
       symmetry in Hp; apply PPermut_Hyb_nil_impl in Hp; destruct l1;
         rew_app in *; discriminate.
       transitivity ((w', y') :: (w, x') :: l1).
         constructor; [ | constructor]; auto.
         PPermut_Hyb_simpl.
       replace l1 with (l1 ++ nil) by (rew_app; auto);
       replace l3 with (l3 ++ nil) by (rew_app; auto);
       apply IH with (w:=w0) (a0:=a) (a'0:=a'); auto;
         rew_app; auto.
  destruct l1; destruct l3; rew_app in *; inversion H6; inversion H7; subst;
    auto.
       apply PPermut_Hyb_nil_impl in Hp; discriminate.
       apply PPermut_Hyb_nil_impl in Hp; destruct l3; rew_app in *; discriminate.
       rewrite <- Hp; PPermut_Hyb_simpl; transitivity ((w,x)::(w0,y)::nil);
         PPermut_Hyb_simpl; constructor; auto; constructor; auto;
         transitivity a'; auto; symmetry; auto.
       transitivity ((w',y')::(w,x')::l1); auto; PPermut_Hyb_simpl; rew_app;
       replace l1 with (l1 ++ nil) by (rew_app; auto);
       apply IH with (w:=w0) (a0:=a) (a'0:=a'); auto;
         rew_app; auto.
  constructor; auto; rewrite <- Hp; symmetry; destruct l1; rew_app in *;
    inversion H6; subst; auto; PPermut_Hyb_simpl; constructor; auto;
    transitivity a'; auto; symmetry; auto.
  destruct l3; rew_app in *; inversion H7; subst.
    symmetry in Hp; apply PPermut_Hyb_nil_impl in Hp; subst; inversion H6; subst;
      destruct l1; rew_app in *; inversion H6; subst; destruct l1; rew_app in *;
      discriminate.
    transitivity ((w', y') ::l1 ++ p0 :: l2); PPermut_Hyb_simpl; rew_app.
    destruct l1; rew_app in *; inversion H6; subst.
      rewrite Hp; PPermut_Hyb_simpl; constructor; auto; transitivity a; auto;
      symmetry; auto.
      constructor; auto; replace l3 with (l3 ++ nil) by (rew_app; auto);
      apply IH with (w:=w0) (a0:=a) (a'0:=a'); auto; rew_app; auto.
  clear H2 H3. destruct l1; destruct l3; rew_app in *; inversion H6;
  inversion H7; subst.
    constructor; auto; transitivity a; auto; transitivity a'; auto;
    symmetry; auto.
    transitivity ((w', y'):: p0 :: l2).
      constructor; auto.
      PPermut_Hyb_simpl. clear H6 H7. rew_app; rewrite Hp; PPermut_Hyb_simpl;
      constructor; auto; transitivity a; auto; symmetry; auto.
    transitivity ((w, x)::p1::l4).
      PPermut_Hyb_simpl; rew_app; rewrite <- Hp; PPermut_Hyb_simpl; constructor;
        auto; transitivity a'; auto; symmetry; auto.
      constructor; auto.
    transitivity ((w', y') :: (w, x') :: l1 ++ p0 :: l2).
      constructor; auto; constructor; auto.
      PPermut_Hyb_simpl. clear H7 H6. rew_app.
    apply IH with (w:=w0) (a0:=a) (a'0:=a'); rew_app; auto.
  (* trans *)
  intros. destruct (PPermut_Hyb_Mem l l' w a) as (a'', (H6a, H6b)); auto.
    subst; rewrite Mem_app_or_eq; left; rewrite Mem_app_or_eq; right;
      apply Mem_here.
  destruct (Mem_split ctx_Hyb l' (w, a'')) as (l'1, (l'2, H6)); auto.
  transitivity (l'1 ++ l'2).
    apply H0 with (w:=w) (a:=a) (a':=a''); [ symmetry | | ]; auto.
    apply H2 with (w:=w) (a:=a'') (a':=a').
      transitivity a; auto; symmetry; auto.
      auto.
      auto.
Qed.

Lemma PPermut_Hyb_last_rev_simpl:
forall G G' a,
  G & a ~=~ G' & a ->
  G ~=~ G'.
intros; replace G with (G ++ nil) by (rew_app; auto);
replace G' with (G'++nil) by (rew_app; auto);
destruct a;
apply PPermut_Hyb_app_rev with (w:=v)(a:=l)(a':=l); rew_app; eauto.
Qed.

Lemma PPermut_Hyb_last_rev:
forall G G' w Gamma Gamma',
  Gamma *=* Gamma' ->
  G & (w, Gamma) ~=~ G' & (w, Gamma') ->
  G ~=~ G'.
intros;
assert (G & (w, Gamma) ~=~ G' & (w, Gamma)) by eauto with ppermut_rew;
apply PPermut_Hyb_last_rev_simpl with (a:=(w, Gamma)); auto.
Qed.

Lemma PPermut_Hyb_split_head:
forall G G' w Gamma,
  (w, Gamma) :: G ~=~ G' ->
  exists Gamma' hd tl,
    Gamma *=* Gamma' /\ G' = hd & (w, Gamma') ++ tl.
intros.
apply PPermut_Hyb_Mem with (w:=w) (X:=Gamma) in H.
destruct H as (Gamma'); destruct H.
exists Gamma'.
assert (exists hd, exists tl, G' = hd & (w, Gamma') ++ tl) by
  (eapply Mem_split; auto).
destruct H1 as (hd, (tl, H1));
exists hd; exists tl; split; [symmetry | ]; auto.
apply Mem_here.
Qed.

Lemma PPermut_Hyb_split_neq:
forall G G' w w' Gamma Gamma',
  G & (w, Gamma) ~=~ G' & (w', Gamma') ->
  ~Gamma *=* Gamma' \/ w <> w' ->
  exists Gamma0, exists GH, exists GT,
    Gamma0 *=* Gamma' /\
    G = GH & (w', Gamma0) ++ GT.
intros.
assert ((w, Gamma) ::G  ~=~ (G' & (w', Gamma'))) by
  (transitivity (G & (w,Gamma)); auto; PPermut_Hyb_simpl).
assert ((w, Gamma) :: G ~=~ (w', Gamma') :: G') by
  (transitivity (G' & (w', Gamma')); auto; PPermut_Hyb_simpl).
symmetry in H2;
apply PPermut_Hyb_split_head in H2;
destruct H2 as (Gamma'',(GH, (GT, (Ha, Hb)))).
destruct GH; rew_app in *.
inversion Hb; subst; destruct H0; elim H0; symmetry; auto.
destruct p; inversion Hb; subst.
exists Gamma''; exists GH; exists GT; split;
[symmetry | rew_app]; auto.
Qed.

Lemma PPermut_Hyb_swap2:
forall C C' G,
  C :: G & C' ~=~ G & C & C'.
intros; PPermut_Hyb_simpl.
Qed.
Hint Resolve PPermut_Hyb_swap2.

Lemma PPermut_Hyb_middle_last:
forall G G' C,
  G ++ G' & C ~=~ G ++ C :: G'.
intros; PPermut_Hyb_simpl.
Qed.
Hint Resolve PPermut_Hyb_middle_last.

Lemma PPermut_Hyb_specialized1:
forall G G' C C',
  G ++ C :: G' & C' ~=~ G ++ G' ++ C' :: C :: nil.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized2:
forall GH GT G Gamma Gamma' Gamma'',
  GH ++ Gamma :: GT & Gamma' ~=~ G & Gamma ->
  GH ++ GT ++ Gamma'' :: Gamma' :: nil ~=~ G & Gamma''.
intros; PPermut_Hyb_simpl;
apply PPermut_Hyb_last_rev_simpl with (a:=Gamma);
rewrite <- H; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized3:
forall G G' C C',
  G ++ G' ++ C :: C' :: nil ~=~ G ++ C :: G' & C'.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized4:
forall G GH GT Gamma Gamma0 Gamma'0,
  GH ++ Gamma :: GT & Gamma'0 ~=~ G & Gamma ->
  G ++ Gamma0 :: Gamma :: nil ~=~ GH ++ GT ++ Gamma0 :: Gamma'0 :: Gamma :: nil.
intros; PPermut_Hyb_simpl;
apply PPermut_Hyb_last_rev_simpl with (a:=Gamma); rewrite <- H;
PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized5:
forall G G' C C' C'',
  G ++ C :: G' ++ C' :: C'' :: nil ~=~ (G ++ G' ++ C' :: C'' :: nil) & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_specialized6:
forall GH GT C0 C'' C'0,
  GH ++ GT ++ C'0 :: C'' :: C0 :: nil ~=~ GH ++ GT ++ C0 :: C'0 :: C'' :: nil.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap_inner:
forall G G' C C',
  C :: G ++ C' :: G' ~=~ C' :: G ++ G' & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap_inner2:
forall G G' C C',
  C :: G ++ G' & C' ~=~ C' :: G ++ G' & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap3:
forall C C' G,
  C :: G & C' ~=~ C' :: G & C.
intros; PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_swap4:
forall C G' G,
  G ++ G' & C ~=~ G & C ++ G'.
intros; PPermut_Hyb_simpl.
Qed.

Hint Resolve PPermut_Hyb_swap_inner.
Hint Resolve PPermut_Hyb_swap_inner2.
Hint Resolve PPermut_Hyb_swap3 PPermut_Hyb_swap4.

Hint Resolve PPermut_Hyb_specialized2 : ppermut_rew.
Hint Resolve PPermut_Hyb_specialized1
             PPermut_Hyb_specialized3 PPermut_Hyb_specialized4
             PPermut_Hyb_specialized5 PPermut_Hyb_specialized6.

Lemma permut_PPermut_Hyb:
forall G G', G *=* G' -> G ~=~ G'.
intros. induction H; auto.
transitivity y; auto.
inversion H. PPermut_Hyb_simpl.
Qed.

Lemma PPermut_Hyb_map_fst:
forall G G',
  G ~=~ G' ->
  map fst_ G *=* map fst_ G'.
induction G; intros.
apply PPermut_Hyb_nil_impl in H; subst; auto.
assert (a::G ~=~ G') by auto;
destruct a; apply PPermut_Hyb_split_head in H;
destruct H as (l', (hd, (tl, (Ha, Hb)))); subst;
rew_map; simpl; permut_simpl;
replace (map fst_ hd ++ map fst_ tl) with (map fst_ (hd++tl))
  by (rew_map; auto);
apply IHG.
apply PPermut_Hyb_last_rev with (w:=v) (Gamma:=l) (Gamma':=l);
auto; transitivity ((v,l)::G); [ | rewrite H0]; PPermut_Hyb_simpl.
Qed.

Close Scope permut_scope.


Require Export Term.
Require Export Formula.

Require Import Base.Lists.
Require Import Base.Permutation.
Require Export Tactics.Equality.
Require Export Tactics.FormulaEquality.
Require Import Tactics.TermEquality.
Require Import Tactics.WellFormedFormulaNoProofs.
Require Import Tactics.TermHasSortNoFormulas.

Import ListNotations.
Module Type SignedSubformula (G : GroundInfo) (GTerm : Term G) (GFormula : Formula G GTerm)
       (TE : TermEquality G GTerm) (FE : FormulaEquality G GTerm GFormula TE).

  Import G. Import GTerm. Import GFormula. Import TE. Import FE. Import ListNotations.

  Open Scope term_scope. Open Scope formula_scope. Open Scope list_scope.

  Inductive Sign : Set :=
    Pos
  | Neg.

  Definition negate : Sign -> Sign :=
    fun g => match g with
          | Pos => Neg
          | Neg => Pos
          end.

  Definition SignedFormula := (flafolFormula * Sign)%type.

  Notation "phi s: g" := ((phi, g ) : SignedFormula) (at level 35).
  Reserved Infix "≤s" (at level 40).

  Inductive SignedSubformulaOf : SignedFormula -> SignedFormula -> Prop :=
  | SSRefl : forall phi : SignedFormula, phi ≤s phi
  | SSTrans : forall phi psi chi : SignedFormula, phi ≤s psi -> psi ≤s chi -> phi ≤s chi
  | SSOrL : forall (phi psi : flafolFormula) (g : Sign),
      (phi s: g) ≤s (phi ⊕ psi s: g)
  | SSOrR : forall (phi psi : flafolFormula) (g : Sign),
      (psi s: g) ≤s (phi ⊕ psi s: g)
  | SSAndL : forall (phi psi : flafolFormula) (g : Sign),
      (phi s: g) ≤s (phi & psi s: g)
  | SSAndR : forall (phi psi : flafolFormula) (g : Sign),
      (psi s: g) ≤s (phi & psi s: g)
  | SSImpL : forall (phi psi : flafolFormula) (l : flafolTerm) (g : Sign),
      (phi s: negate g) ≤s (phi ==⟨ l ⟩> psi s: g)
  | SSImpR : forall (phi psi : flafolFormula) (l : flafolTerm) (g : Sign),
      (psi s: g) ≤s (phi ==⟨ l ⟩> psi s: g)
  | SSForallNeg : forall (phi : flafolFormula) (s : G.sort) (t : flafolTerm),
      ⊢s t ::: s -> (open_formula phi t s: Neg) ≤s (∀ s; phi s: Neg)
  | SSForallPos : forall (phi : flafolFormula) (s : G.sort) (x : var),
      VarSort x = s ->
      (open_formula phi (varTerm x) s: Pos) ≤s (∀ s; phi s: Pos)
  | SSExistsPos : forall (phi : flafolFormula) (s : G.sort) (t : flafolTerm),
      ⊢s t ::: s -> (open_formula phi t s: Pos) ≤s (∃ s; phi s: Pos)
  | SSExistsNeg : forall (phi : flafolFormula) (y : var) (s : G.sort),
      VarSort y = s ->
      (open_formula phi (varTerm y) s: Neg) ≤s (∃ s; phi s: Neg)
  | SaysInner : forall (phi : flafolFormula) (g : Sign) (p lab : flafolTerm),
      ⊢s p ::: Principal -> ⊢s lab ::: Label ->
      (phi s: g) ≤s (p □ ⟨ lab ⟩ phi s: g)
  where "phi ≤s psi" := (SignedSubformulaOf phi psi).

  Lemma FlowsToOnlySub : forall (t u : flafolTerm) (phi : SignedFormula) (g : Sign),
      phi ≤s (t ⊑ u s: g) -> phi = (t ⊑ u s: g).
  Proof.
    intros t u phi g.
    generalize (eq_refl (t ⊑ u s: g)). generalize (t ⊑ u s: g) at 1 3 4.
    intros s H H0.
    induction H0; auto; try (inversion H; auto; fail).
    rewrite <- IHSignedSubformulaOf2; auto. rewrite <- IHSignedSubformulaOf1; auto.
    rewrite IHSignedSubformulaOf2; auto.
  Qed.

  Lemma CanROnlySub : forall(p l : flafolTerm) (phi : SignedFormula) (g : Sign),
      phi ≤s (canRead p l s: g) -> phi = (canRead p l s: g).
  Proof.
    intros p l phi g.
    generalize (eq_refl (canRead p l s: g)). generalize (canRead p l s: g) at 1 3 4.
    intros s H H0.
    induction H0; auto; try (inversion H; auto; fail).
    rewrite <- IHSignedSubformulaOf2; auto. rewrite <- IHSignedSubformulaOf1; auto.
    rewrite IHSignedSubformulaOf2; auto.
  Qed.

  Lemma CanWOnlySub : forall(p l : flafolTerm) (phi : SignedFormula) (g : Sign),
      phi ≤s (canWrite p l s: g) -> phi = (canWrite p l s: g).
  Proof.
    intros p l phi g.
    generalize (eq_refl (canWrite p l s: g)). generalize (canWrite p l s: g) at 1 3 4.
    intros s H H0.
    induction H0; auto; try (inversion H; auto; fail).
    rewrite <- IHSignedSubformulaOf2; auto. rewrite <- IHSignedSubformulaOf1; auto.
    rewrite IHSignedSubformulaOf2; auto.
  Qed.

  Ltac FindEqualSign := idtac.
  Ltac FindEqualSign' l :=
    match goal with
    | [ H : ?P |- ?P ] => exact H
    | [ H : Pos = Neg |- _ ] => inversion H
    | [ H : Neg = Pos |- _ ] => inversion H
    | [ e : ?g = ?g' |- ?g' = ?g ] => exact (eq_sym e)
    | [ e : ?g = ?g' |- ?g = ?g''] =>
      NotInList g' l; transitivity g'; [exact e | FindEqualSign' constr:(g' :: l)]
    end.
  Ltac FindEqualSign ::= FindEqualSign' constr:(@nil Sign).

  Lemma UnifySignedFormula : forall g g' phi psi, phi = psi -> g = g' -> (phi s: g) = (psi s: g').
  Proof.
    intros g g' phi psi H H0; rewrite H; rewrite H0; reflexivity.
  Qed.
  Ltac FindEqualSignedFormula := idtac.
  Ltac FindEqualSignedFormula' l :=
    match goal with
    | [ H : ?P |- ?P ] => exact H
    | [ e : ?phi = ?psi |- ?psi = ?phi ] => exact (eq_sym e)
    | [ |- (?phi s: ?g) = (?psi s: ?g') ] => apply UnifySignedFormula;
                                       [ FindFormulaEquality | FindEqualSign]
    | [ e : ?phi = ?psi |- ?phi = ?chi ] =>
      NotInList psi l; transitivity psi; [exact e | FindEqualSignedFormula' constr:(psi :: l)]
    end.
  Ltac FindEqualSignedFormula ::= FindEqualSignedFormula' constr:(@nil SignedFormula).

  Lemma UnifySubformula : forall phi psi : SignedFormula, phi = psi -> phi ≤s psi.
  Proof.
    intros phi psi H; rewrite H; apply SSRefl.
  Qed.

  Lemma UnifyGSSImpL : forall phi psi l g g',
      g' = negate g -> (phi s: g') ≤s (phi ==⟨ l ⟩> psi s: g).
  Proof.
    intros phi psi l g g' H; rewrite H; apply SSImpL.
  Qed.

  Ltac FindSignedSubformula := idtac.
  Ltac FindSignedSubformula' l :=
    match goal with
    | [ H : ?P |- ?P ] => exact H
    | [ |- ?phi ≤s ?phi ] => apply SSRefl
    | [ |- ?phi ≤s ?psi ] =>
      apply UnifySubformula; FindEqualSignedFormula
    | [ H: ?phi ≤s ?psi  |- ?phi ≤s ?chi ] =>
      NotInList psi l; apply (SSTrans phi psi chi); [exact H | FindSignedSubformula' constr:(psi :: l)]
    | [ |- (?phi, ?g) ≤s (?phi ⊕ _, ?g) ] =>
      apply SSOrL
    | [ |- (?phi, ?g) ≤s (_ ⊕ ?phi, ?g) ] =>
      apply SSOrR
    | [ |- (?phi, ?g) ≤s (?phi & _, ?g) ] =>
      apply SSAndL
    | [ |- (?phi, ?g) ≤s (_ & ?phi, ?g) ] =>
      apply SSAndR
    | [ |- (?phi, ?g') ≤s (?phi ==⟨ _ ⟩> _, ?g)] =>
        apply UnifyGSSImpL; simpl; FindEqualSign
    | [ |- ?phi ≤s _ ==⟨ _ ⟩> ?phi ] =>
      apply SSImpR
    | [ |- ?p □ ⟨?lab⟩ ?phi ≤s ?p □ ⟨?lab⟩ ?psi ] =>
      apply SaysInner; [auto | auto | FindSignedSubformula]
    end.
  Ltac FindSignedSubformula ::= FindSignedSubformula' constr:(@nil SignedFormula).

End SignedSubformula.


(* --------------------------------------------------------------------
 * (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 bigop ssralg ssrfun ssrint.
From mathcomp Require Import ssrnum generic_quotient.

Require Import fracfield fraction polyall polyfrac polydec.
Require Import ec ecpoly eceval ecorder freeg.

Import GRing.Theory.
Import Num.Theory.
Import FracField.

Open Local Scope ring_scope.
Open Local Scope quotient_scope.

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

(* -------------------------------------------------------------------- *)
Lemma inj_pair1 (T U : Type) (x : T):
  injective (fun (y : U) => (x, y)).
Proof. by move=> y1 y2 /= []. Qed.

Lemma inj_pair2 (T U : Type) (y : T):
  injective (fun (x : U) => (x, y)).
Proof. by move=> x1 x2 /= []. Qed.

Lemma pairE (T U : Type) (p : T * U): (p.1, p.2) = p.
Proof. by case: p. Qed.

Local Hint Immediate inj_pair1 inj_pair2.

Reserved Notation "D1 :~: D2" (at level 70, no associativity).

(* -------------------------------------------------------------------- *)
Section ECDiv.
  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).

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

  Implicit Types f : ecpoly.

  (* ------------------------------------------------------------------ *)
  Definition ecdivp (f : ecpoly) : {freeg (point K)} :=
    locked (
      \sum_(p <- ecroots f) << (order f%:F (|p.1, p.2|)) *g (|p.1, p.2|) >>
    + << order f%:F ∞ *g ∞ >>).

  Lemma ecdivpE (f : ecpoly) (p : point K):
    coeff p (ecdivp f) = order f%:F p.
  Proof.
    rewrite /ecdivp; unlock; rewrite raddfD raddf_sum /= coeffU.
    pose F q := (order f%:F (|q.1, q.2|)) * ((|q.1, q.2|) == p).
    rewrite (eq_bigr F); last first.
      by move=> q _; rewrite coeffU {}/F natz.
    rewrite {}/F; case: p => [|x y].
      by rewrite big1 => [|i _] /=; rewrite !Monoid.simpm.
    rewrite !Monoid.simpm; case: (order f%:F (|x, y|) =P 0).
    + move=> z_ordfxy; rewrite z_ordfxy big_seq big1 //.
      move=> [q1 q2] /= q_ecrf; set q := (|q1, q2|).
      case: (q =P (|x, y|)); last by rewrite mulr0.
      by move=> Eq; move:z_ordfxy; rewrite Eq => ->.
    + move/eqP; rewrite -ecroots_order => xy_in_ecrf.
      rewrite (bigD1_seq _ xy_in_ecrf) ?ecroots_uniq //=.
      rewrite eqxx mulr1 big1 ?addr0 //.
      by case=> i1 i2 /=; rewrite !eqE /= => /negbTE ->; rewrite mulr0.
  Qed.

  Lemma ecdivpC c: ecdivp (c%:P)%:E = 0.
  Proof.
    apply/eqP; apply/freeg_eqP => p.
    by rewrite coeff0 ecdivpE orderC.
  Qed.

  Lemma ecdivp0: ecdivp 0 = 0.
  Proof. by rewrite ecdivpC. Qed.

  Lemma ecdivpM (f g : ecpoly): f * g != 0 ->
    ecdivp (f * g) = (ecdivp f) + (ecdivp g).
  Proof.
    move=> nz_fg; apply/eqP; apply/freeg_eqP => p.
    rewrite coeffD !ecdivpE tofracM order_mul //.
    by rewrite -tofracM tofrac_eq0.
  Qed.

  Lemma ecdivp_prod (I : Type) (r : seq I) (F : I -> ecpoly):
       \prod_(i <- r) F i != 0
    -> ecdivp (\prod_(i <- r) F i) = \sum_(i <- r) (ecdivp (F i)).
  Proof.
    elim: r => [|r rs IH].
      by move=> _; rewrite !big_nil ecdivpC.
    rewrite !big_cons => nz_prod; rewrite ecdivpM ?IH //=.
    by move: nz_prod; rewrite mulf_eq0; case/norP.
  Qed.

  Lemma orderF_line (c x y : K): c != x ->
    order (('X - c%:P)%:E)%:F (|x, y|) = 0.
  Proof.
    move=> ne_cx; case oncve: (oncurve (|x, y|)); last first.
      by rewrite order_outcve ?oncve.
    apply/eqP/eval_eq0_orderP => //.
      by rewrite tofrac_eq0 ecX_eq0 polyXsubC_eq0.
    exists (x - c); first by rewrite subr_eq0 eq_sym.
    by rewrite eval_finF // ecevalE /= !hornerE.
  Qed.

  Lemma ecdivp_line (x y : K): oncurve (|x, y|) ->
      ecdivp ('X - x%:P)%:E
    = << (|x, y|) >> + << (|x, -y|) >> - << 2%:Z *g ∞ >>.
  Proof.
    move=> oncve; apply/eqP; apply/freeg_eqP => p.
    rewrite ecdivpE !(coeffD, coeffN, coeffU) !mul1r.
    case: p => [|p1 p2] /=.
      by rewrite !add0r mulr1 orderF_inf degree_pX size_XsubC.
    rewrite mulr0 subr0; case: (x =P p1) oncve => [->|]; last first.
      move/eqP=> ne_x_p1 _; rewrite !eqE /= (negbTE ne_x_p1) /= addr0.
      by rewrite orderF_line.
    move=> oncve; rewrite !eqE /= eqxx /=.
    case oncve_p: (oncurve (|p1, p2|)); last first.
      rewrite order_outcve ?oncve_p // !natz; apply/eqP.
      rewrite eqz_nat eq_sym addn_eq0 eqr_oppLR !eqb0 -negb_or.
      rewrite -eqr_sqr (eqP oncve) eq_sym; move: oncve_p.
      by move=> /= ->.
    move: oncve_p; rewrite /= -(eqP oncve); case: (y =P 0) oncve.
      move=> -> oncve; rewrite expr0n expf_eq0 /= => /eqP ->.
      rewrite oppr0 eqxx /= -PoszD /= addn1 orderS //.
      by rewrite Xpoly_oncurve.
    move=> /eqP; case: (-y =P p2); case: (y =P p2) => /=.
    + by move=> -> /esym /ecu_eq_oppr ->; rewrite !eqxx.
    + move=> _ /eqP; rewrite eqr_oppLR => /eqP ->.
      rewrite oppr_eq0 sqrrN => nz_p2 oncve _.
      by rewrite orderR ?add0r.
    + by move=> -> _ nz_p2 oncve _; rewrite orderR ?addr0.
    + move=> /eqP ne_y_p2 /eqP ne_yN_p2 _ _; rewrite eqr_sqr.
      by rewrite ![p2 == _]eq_sym (negbTE ne_y_p2) (negbTE ne_yN_p2).
  Qed.

  Local Notation ecdeg f := (deg (ecdivp f)).

  Lemma ecdeg0: ecdeg 0 = 0.
  Proof. by rewrite ecdivp0 deg0. Qed.

  Lemma ecdegC c: ecdeg (c%:P)%:E = 0.
  Proof. by rewrite ecdivpC deg0. Qed.

  Lemma ecdegM f g: f * g != 0 -> ecdeg (f * g) = (ecdeg f) + (ecdeg g).
  Proof. by move=> nz_fg; rewrite ecdivpM // degD. Qed.

  Lemma ecdeg_conjp f: ecdeg (conjp f) = ecdeg f.
  Proof.
    rewrite /ecdivp; unlock; rewrite !degD !raddf_sum /=.
    rewrite -order_conj /= conjF conjpK; congr (_ + _).
    rewrite (eq_big_perm _ (ecroots_conjp f)) /= big_map /=.
    apply: eq_bigr=> p _; rewrite -order_conj /= !degU.
    by rewrite conjF conjpK opprK.
  Qed.

  Lemma ecdeg_norm f:
    ecdeg ((normp f)%:E) = 2%:Z * (deg (ecdivp f)).
  Proof.
    case: (f =P 0) => [->|/eqP nz_f].
      by rewrite norm0 ecdeg0 mulr0.
    rewrite -[_%:E]conjp_normp ecdegM; last first.
      by rewrite mulf_neq0 ?conjp_eq0.
    by rewrite ecdeg_conjp mul2z.
  Qed.

  Hypothesis closed : GRing.ClosedField.axiom K.

  Local Notation clK := (ClosedFieldType K closed).

  Lemma ecdeg_eq0 f: ecdeg f = 0.
  Proof.
    case: (f =P 0) => [->|/eqP nz_f].
      by rewrite ecdeg0.
    apply: (@mulfI _ 2%:Z) => //; rewrite mulr0.
    rewrite -ecdeg_norm [normp _](@roots_factor_theorem_f clK).
    rewrite -mul_polyC ecXM ecdegM; last first.
      rewrite mulf_neq0 //.
      + by rewrite ecX_eq0 polyC_eq0 lead_coef_eq0 norm_eq0.
      + rewrite ecX_eq0 prodf_seq_neq0; apply/allP => c _.
        by apply/implyP => _; rewrite polyXsubC_eq0.
    rewrite ecdegC add0r; move: (rmorph_prod (ecX_rmorphism E)) => /= ->.
    rewrite ecdivp_prod; last first.
      rewrite prodf_seq_neq0; apply/allP=> c _; apply/implyP=> _.
      by rewrite ecX_eq0 polyXsubC_eq0.
    rewrite raddf_sum /= big_seq big1 // => x x_root.
    pose y := sqrt (Xpoly.[x]); have oncve: (oncurve (|x, y|)).
      by rewrite /= {}/y (@sqr_sqrt clK) -horner_Xpoly.
    rewrite (ecdivp_line oncve) !(raddfB, raddfD) /= !degU.
    by rewrite -PoszD subrr.
  Qed.

  (* ------------------------------------------------------------------ *)
  Definition ecdiv_r (f : {ratio ecpoly}) :=
    if \n_f == 0 then 0 else (ecdivp \n_f) - (ecdivp \d_f).

  Definition ecdiv :=
    lift_fun1 {fraction ecpoly} ecdiv_r.

  Lemma pi_ecdiv: {mono \pi_{fraction ecpoly} : f / ecdiv_r f >-> ecdiv f}.
  Proof.
    move=> f2; unlock ecdiv; set f1 := (repr _).
    have: (f1 = f2 %[mod {fraction _}]) by rewrite reprK.
    case: f2 f1 => [[n2 d2] /= nz_d2] [[n1 d1] /= nz_d1] /=.
    move/eqmodP => /=; rewrite FracField.equivfE /= => /eqP eqr.
    apply/eqP; rewrite /ecdiv_r /=.
    move/eqP: eqr;
      have [->|nz_n1] := eqVneq n1 0;
      have [->|nz_n2] := eqVneq n2 0;
        rewrite ?eqxx //.
    * by rewrite eq_sym mul0r mulf_eq0; case/norP.
    * by rewrite mulr0 mulf_eq0; case/norP.
    move/eqP=> eqr; rewrite (negbTE nz_n1) (negbTE nz_n2).
    by rewrite addr_cross -!ecdivpM ?eqr ?[d1 * n2]mulrC // mulf_neq0.
  Qed.

  Canonical ecdiv_morph := PiMono1 (pi_ecdiv).

  Import fracfield.FracField.

  Lemma ecdiv0: ecdiv 0 = 0.
  Proof.
    rewrite !piE /Ratio /insubd insubT ?oner_eq0 //=.
    by rewrite /ecdiv_r /= eqxx.
  Qed.

  Lemma ecdivE (n d : ecpoly): n * d != 0 ->
    ecdiv (n // d) = (ecdivp n) - (ecdivp d).
  Proof.
    rewrite mulf_eq0 => /norP [nz_n nz_d]; rewrite embed_Ratio !piE.
    rewrite /Ratio /insubd insubT /= /ecdiv_r /=.
    by rewrite (negbTE nz_n).
  Qed.

  Lemma ecdivC c: ecdiv ((c%:P)%:E)%:F = 0.
  Proof.
    have [->|nz_c] := eqVneq c 0; first by rewrite ecdiv0.
    rewrite -[_%:F]divr1 -[1]tofrac1 ecdivE; last first.
      by rewrite mulf_neq0 ?oner_eq0 // ecX_eq0 polyC_eq0.
    by rewrite !ecdivpC subrr.
  Qed.

  Lemma ecdiv_coeffE (f : {fraction ecpoly}) p:
    coeff p (ecdiv f) = order f p.
  Proof.
    elim/FracField.fracW: f => n d nz_d.
    case: (n =P 0) => [->|/eqP nz_n].
      by rewrite mul0r ecdiv0 coeff0 order0.
    rewrite ecdivE ?mulf_neq0 // coeffB !ecdivpE.
    by rewrite orderE // -!orderF.
  Qed.

  Lemma ecdivF f: ecdiv f%:F = ecdivp f.
  Proof.
    have [->|nz_f] := eqVneq f 0; first by rewrite ecdiv0 ecdivp0.
    rewrite -[f%:F]divr1 -[1]tofrac1 ecdivE; last first.
      by rewrite mulf_neq0 // oner_eq0.
    by rewrite ecdivpC subr0.
  Qed.

  Lemma ecdivM (f g : {fraction ecpoly}): f * g != 0 ->
    ecdiv (f * g) = (ecdiv f) + (ecdiv g).
  Proof.
    move=> nz_fg; apply/eqP; apply/freeg_eqP => p.
    by rewrite coeffD !ecdiv_coeffE order_mul.
  Qed.

  Lemma ecdiv_prod (I : Type) (r : seq I) (F : I -> {fraction ecpoly}) (P : pred I):
       \prod_(i <- r | P i) F i != 0
    -> ecdiv (\prod_(i <- r | P i) F i) = \sum_(i <- r | P i) (ecdiv (F i)).
  Proof.
    elim: r => [|i r IH]; first by rewrite !big_nil ecdivC.
    rewrite !big_cons; case: (P i) => nz; last by rewrite IH.
    move: nz; rewrite mulf_eq0 => /norP [nz_Fi nz].
    by rewrite ecdivM ?mulf_neq0 // IH.
  Qed.

  Lemma ecdivX (f : {fraction ecpoly}) n:
    ecdiv (f ^+ n) = (ecdiv f) *+ n.
  Proof.
    have [->|nz_f] := eqVneq f 0.
      rewrite expr0n ecdiv0 mul0rn.
      by case: (n == 0)%N; rewrite ecdivC.
    elim: n => [|n IH].
      by rewrite expr0 mulr0n ecdivC.
    rewrite exprS ecdivM; last first.
      by rewrite mulf_neq0 ?expf_neq0.
    by rewrite IH mulrS.
  Qed.

  Lemma ecdivV (f : {fraction ecpoly}):
    ecdiv (f^-1) = - (ecdiv f).
  Proof.
    apply/eqP; apply/freeg_eqP=> p.
    by rewrite coeffN !ecdiv_coeffE order_inv.
  Qed.

  Lemma ecdivXz (f : {fraction ecpoly}) z:
    ecdiv (f ^ z) = (ecdiv f) *~ z.
  Proof.
    case: z => n.
    + by rewrite ecdivX.
    + by rewrite NegzE /= -exprnN ecdivV ecdivX.
  Qed.

  Lemma ecdiv_eq0 (f : {fraction ecpoly}): deg (ecdiv f) = 0.
  Proof.
    elim/fracW: f => n d nz_d; have [->|nz_n] := eqVneq n 0.
      by rewrite mul0r ecdiv0 deg0.
    by rewrite ecdivE ?mulf_neq0 // degB !ecdeg_eq0 subrr.
  Qed.

  Lemma mem_negdiv R (f :{fraction ecpoly}):
    (R \in dom (fgneg (ecdiv f))) = (order f R < 0).
  Proof.
    rewrite mem_dom inE coeff_fgnegE oppr_eq0 eqr_minl.
    by rewrite -ltrNge ecdiv_coeffE.
  Qed.

  Lemma mem_posdiv R (f : {fraction ecpoly}):
    (R \in dom (fgpos (ecdiv f))) = (order f R > 0).
  Proof.
    rewrite mem_dom inE coeff_fgposE eqr_maxl.
    by rewrite -ltrNge ecdiv_coeffE.
  Qed.

  (* -------------------------------------------------------------------- *)
  Lemma deg_ecdiv_eq0 (f : {fraction ecpoly}): deg (ecdiv f) = 0.
  Proof.
    have [->|] := eqVneq f 0; first by rewrite ecdiv0 deg0.
    elim/fracW: f => n d _; rewrite mulf_eq0 invr_eq0 !tofrac_eq0.
    case/norP=> nz_n nz_d; rewrite ecdivE ?mulf_neq0 //.
    by rewrite degB !ecdeg_eq0.
  Qed.

  (* ------------------------------------------------------------------ *)
  Lemma div_sumE (D : {freeg point K}):
    D = << coeff ∞ D *g ∞ >> + \sum_(z <- dom D | z != ∞) << coeff z D *g z >>.
  Proof.
    rewrite -{1}[D]freeg_sumE; case i_in_D: (∞ \in dom D).
      by rewrite (bigD1_seq ∞) ?uniq_dom.
    rewrite coeff_outdom ?i_in_D // freegU0 add0r.
    rewrite -[X in _ = X]big_filter; set d := [seq _ <- _ | _].
    have ->//: d = dom D; rewrite {}/d.
    rewrite (eq_in_filter (a2 := predT)) ?filter_predT //.
    move=> z zD /=; apply/negP=> /eqP zi; move: zD.
    by rewrite zi i_in_D.
  Qed.

  Lemma ecdiv_sumE (f : {fraction ecpoly}):
    ecdiv f = \sum_(z <- dom (ecdiv f)) << order f z *g z >>.
  Proof.
    rewrite -{1}[ecdiv _]freeg_sumE; apply: eq_bigr.
    by move=> p _; rewrite ecdiv_coeffE.
  Qed.

  Lemma ecdiv_degE (f : {fraction ecpoly}):
    deg (ecdiv f) = \sum_(R <- dom (ecdiv f)) order f R.
  Proof.
    rewrite -{1}[ecdiv _]freeg_sumE raddf_sum /=.
    by apply: eq_bigr => p _; rewrite degU ecdiv_coeffE.
  Qed.

  Section DivIndDom.
    Variable P : {freeg (point K)} -> Prop.

    Hypothesis H0: forall k, P << k *g ∞ >>.
    Hypothesis HS:
      forall k p D, p \notin dom D -> k != 0 -> p != ∞ ->
        P D -> P (<< k *g p >> + D).

    Lemma div_ind_dom D: P D.
    Proof.
      apply: (@freeg_ind_dom _ _ (pred1 (∞ : point K))) => {D}; last first.
        by move=> k p D /= p_notin_D nz_k nz_p PD; apply: HS.
      move=> D domD; rewrite {1}[D]div_sumE -big_filter.
      set s := [seq _ <- _ | _]; have ->: s = [::]; last first.
        by rewrite big_nil addr0; apply: H0.
      rewrite {}/s; case sE: [seq _ <- _ | _] => [//|x xs].
      have: x \in x :: xs by rewrite in_cons eqxx.
      rewrite -sE mem_filter andbC; move/(_ x): domD.
      by rewrite !inE => ->.
    Qed.
  End DivIndDom.

  (* -------------------------------------------------------------------- *)
  Local Notation PEF       := (@tofrac _ \o ((ecX E) \o polyC)).
  Local Notation "x %:PEF" := (PEF x) (at level 2).
  Local Notation "'Y"      := [ecp 1 *Y + 0].

  Lemma Necdiv_transE (f : {fraction ecpoly}) (c : K):
    fgneg (ecdiv (f + c%:PEF)) = fgneg (ecdiv f).
  Proof.
    have h:
      forall (f : {fraction ecpoly}) (c : K) p,
        order f p < 0 -> order f p = order (f + c%:PEF) p.
    + move=> {f c} f c p; case oncve: (oncurve p); last first.
        by rewrite order_outcve // oncve.
      have [->|nz_c] := eqVneq c 0; first by rewrite /= addr0.
      have [->|nz_f] := eqVneq f 0; first by rewrite order0.
      pose n := (decomp f p).1; have nz_n: n != 0 by apply: decomp_nz_num.
      pose d := (decomp f p).2; have nz_d: d != 0 by apply: decomp_nz_den.
      pose o := order f p; pose u := unifun E p.
      have:= (decomp_correct nz_f oncve); rewrite -/u -{1}/o -/n -/d => uok.
      have: f + c%:PEF = (u ^ o * ((n%:F + u^(-o) * (c%:PEF * d%:F)) / d%:F)).
        rewrite mulrA mulrDr mulrA -expfzDr ?unifun_neq0 //.
        rewrite subrr expr0z mul1r mulrDl -!mulrA divff ?tofrac_eq0 //.
        by rewrite mulr1 (uniok_decomp uok).
      set g := (_ / _); have [->|nz_g] := eqVneq g 0.
        move/eqP; rewrite mulr0 addr_eq0 => /eqP {1}->.
        by rewrite order_opp orderC.
      move=> eq; rewrite eq order_mul; last first.
        by rewrite mulf_neq0 // expfz_neq0 // unifun_neq0.
      rewrite order_expz; move: (uniformizer_unifun oncve).
      rewrite /uniformizer -{2}/o => /eqP ->; rewrite intz.
      move=> ordf_lt0; apply/eqP; rewrite addrC -subr_eq.
      rewrite subrr eq_sym; move: {eq} nz_g; rewrite {}/g -[-o]ltz0_abs //.
      move: n d nz_n nz_d uok => n d nz_n nz_d; rewrite {}/u.
      move: (erefl o); rewrite {2}/o => oE.
      case: p oncve o oE ordf_lt0 => [|x y] oncve o oE ordf_lt0 /= uok.
      + set r := (_ + _); have ->: r =
            (n * 'Y^+`|o| + 'X%:E^+`|o| * (c%:P%:E) * d) // 'Y^+`|o|.
          rewrite {}/r -!exprnP divf_exp mulrAC mulrA -!(tofracX, tofracM).
          rewrite -{1}[n%:F]divr1 -[1]tofrac1 addf_div; first last.
          * by rewrite tofrac_eq0 expf_neq0 // ecY_neq0.
          * by rewrite oner_eq0.
          by rewrite !(mul1r, mulr1) -!(tofracX, tofracM, tofracD).
        rewrite -![_ / d%:F]mulrA -invfM -tofracM.
        rewrite mulf_eq0 {1}invr_eq0 2!tofrac_eq0; case/norP => [nz1 nz2].
        rewrite orderE //= /poly_order /= (negbTE nz1) (negbTE nz2) /=.
        rewrite subr_eq0; apply/eqP; congr (- _); congr (_.-1).
        rewrite degree_addl; last first.
          pose neq0 := (mulf_neq0, expf_neq0, ecX_neq0, ecY_neq0, ecX_eq0, polyC_eq0).
          rewrite [n*_]mulrC !degree_mul_id ?neq0 // => {neq0}.
          rewrite degreeC // (uniok_inf_degeq uok).
          rewrite !(degree_expX, degree_expY) addn1 /= ltn_add2r.
          by rewrite ltn_mul2r oE absz_gt0 neqr_lt ordf_lt0.
        rewrite mulrC !degree_mul_id ?(mulf_neq0, expf_neq0, ecY_neq0) //.
        by rewrite (uniok_inf_degeq uok).
      + rewrite -!exprnP -!(tofracX, tofracM, tofracD) => nz.
        apply/eval_eq0_orderP => //; rewrite evalE_fin_ord_ge0 //; last first.
          by apply (uniok_fin_den_eval_neq0 uok).
        set v1 := (_ + _); exists (v1.[x, y] / d.[x, y]) => //.
        rewrite mulf_eq0 invr_eq0 negb_or (uniok_fin_den_eval_neq0 uok) andbT.
        rewrite /v1 !(eceval_add, eceval_mul, eceval_exp) //.
        rewrite eceval_unifun_fin expr0n oE absz_eq0 eqr_le.
        rewrite [0 <= _]lerNgt ordf_lt0 andbF mul0r addr0.
        by rewrite (uniok_fin_num_eval_neq0 uok).
    apply/eqP/freeg_eqP=> R; rewrite !coeff_fgnegE !ecdiv_coeffE.
    have [oncve_R|outcve_R] := (boolP (oncurve R)); last first.
      by rewrite !order_outcve.
    case: (ltrP (order f R) 0); first by move/(h _ c) => <-.
    move=> ge0_ordfR; have/eval_ge0_orderP [x evalhR] := ge0_ordfR.
    have: (0 <= order (f + c%:PEF) R).
      apply/eval_ge0_orderP; exists ((evalK R f) + c).
      by rewrite evalDr evalC // /evalK evalhR.
    by move=> ge0_ordfDcR; rewrite !minr_l.
  Qed.

  (* ------------------------------------------------------------------ *)
  Definition ecdeqv D1 D2 :=
    (exists f : {fraction ecpoly}, ecdiv f = D1 - D2).

  Local Notation "D1 :~: D2" := (ecdeqv D1 D2).

  Lemma ecdeqv_refl D: D :~: D.
  Proof. by rewrite /ecdeqv; exists 0; rewrite ecdiv0 subrr. Qed.

  Lemma ecdeqv_sym D1 D2: D1 :~: D2 -> D2 :~: D1.
  Proof.
    by case=> f divf; exists (f^-1); rewrite ecdivV divf opprB.
  Qed.

  Lemma ecdeqv_trans D1 D2 D3: D1 :~: D2 -> D2 :~: D3 -> D1 :~: D3.
  Proof.
    move=> [f1 divf1] [f2 divf2].
    case: (f1 =P 0) divf1 => [-> /eqP|/eqP nz_f1 divf1].
      by rewrite ecdiv0 eq_sym subr_eq0 => /eqP->; exists f2.
    case: (f2 =P 0) divf2 => [-> /eqP|/eqP nz_f2 divf2].
      by rewrite ecdiv0 eq_sym subr_eq0 => /eqP<-; exists f1.
    exists (f1 * f2); rewrite ecdivM ?mulf_neq0 //.
    rewrite divf1 divf2 addrC addrCA [X in _ + X]addrAC.
    by rewrite subrr add0r.
  Qed.

  Lemma ecdeqv_opp D1 D2: D1 :~: D2 -> -D1 :~: -D2.
  Proof.
    by case=> [f divf]; exists (f^-1); rewrite ecdivV -opprD divf.
  Qed.

  Lemma ecdeqv_oppI D1 D2: -D1 :~: -D2 -> D1 :~: D2.
  Proof.
    case=> [f divf]; exists (f^-1).
    by rewrite ecdivV divf opprD !opprK.
  Qed.

  Lemma ecdeqv_addl D1 D1' D2:
    D1 :~: D1' -> (D1 + D2) :~: (D1' + D2).
  Proof.
    case=> [f1 divf1]; exists f1.
    by rewrite -addrA opprD [D2 + _]addrCA subrr addr0.
  Qed.

  Lemma ecdeqv_addIl D1 D1' D2:
    (D1 + D2) :~: (D1' + D2) -> D1 :~: D1'.
  Proof.
    case=> [f1 divf1]; exists f1; rewrite divf1.
    by rewrite -addrA opprD [D2 + _]addrCA subrr addr0.
  Qed.

  Lemma ecdeqv_addr D1 D2 D2':
    D2 :~: D2' -> (D1 + D2) :~: (D1 + D2').
  Proof.
    by move=> eqv_D2; rewrite ![D1 + _]addrC; apply: ecdeqv_addl.
  Qed.

  Lemma ecdeqv_addIr D1 D2 D2':
    (D1 + D2) :~: (D1 + D2') -> D2 :~: D2'.
  Proof. by rewrite ![D1 + _]addrC => /ecdeqv_addIl. Qed.

  Lemma ecdeqv_add D1 D1' D2 D2':
    D1 :~: D1' -> D2 :~: D2' -> (D1 + D2) :~: (D1' + D2').
  Proof.
    move=> eqvD1 eqvD2; apply: (@ecdeqv_trans _ (D1 + D2')).
    + by apply: ecdeqv_addr. + by apply: ecdeqv_addl.
  Qed.

  Lemma ecdeqv_sub D1 D1' D2 D2':
    D1 :~: D1' -> D2 :~: D2' -> (D1 - D2) :~: (D1' - D2').
  Proof.
    by move=> eqvD1 eqvD2; apply: ecdeqv_add => //; apply: ecdeqv_opp.
  Qed.

  Lemma ecdeqv_deg D1 D2: D1 :~: D2 -> deg D1 = deg D2.
  Proof.
    case=> f /esym/eqP; rewrite subr_eq => /eqP->.
    by rewrite degD ecdiv_eq0 ?add0r.
  Qed.

  Lemma ecdeqv_lineS (p : point K):
    oncurve p -> (<<p>> + <<\- p>> - << 2%:Z *g ∞ >>) :~: 0.
  Proof.
    case: p=> [|x y] oncve /=.
    + by rewrite freegUD freegUB freegU0; apply ecdeqv_refl.
    + move/ecdivp_line: oncve; set f := (ecX _ _) => divf.
      by exists f%:F; rewrite subr0 ecdivF divf.
  Qed.

  (* ------------------------------------------------------------------ *)
  Definition ecnorm (D : {freeg point K}) := deg (fgnorm D) - `|coeff ∞ D|.

  Lemma ecnormE D: ecnorm D = \sum_(z <- dom D | z != ∞) `|coeff z D|.
  Proof.
    rewrite /ecnorm fgnormE raddf_sum /=; case iD: (∞ \in dom D).
    + rewrite (bigD1_seq ∞) ?uniq_dom //= degU addrAC.
      by rewrite subrr add0r; apply: eq_bigr=> i _; rewrite degU.
    + rewrite -[X in _ = X]big_filter; set d := [seq _ <- _ | _].
      rewrite coeff_outdom ?iD // normr0 subr0.
      have ->: d = dom D; last by apply: eq_bigr=> i _; rewrite degU.
      rewrite {}/d (eq_in_filter (a2 := predT)) ?filter_predT //.
      move=> z zD /=; apply/negP=> /eqP zi; move: zD.
      by rewrite zi iD.
  Qed.

  Lemma ecnorm0: ecnorm 0 = 0.
  Proof. by rewrite ecnormE dom0 big_nil. Qed.

  Lemma ecnormU k p: ecnorm << k *g p >> = `|k| * (p != ∞).
  Proof.
    case: (k =P 0) => [->|/eqP k_neq0].
      by rewrite freegU0 ecnorm0 normr0 mul0r.
    rewrite ecnormE domU // big_cons big_nil.
    case: (p != ∞); rewrite (mulr0, mulr1) // addr0.
    by rewrite coeffU eqxx mulr1.
  Qed.

  Lemma ecnormD (D1 D2 : {freeg (point K)}):
       [predI (dom D1) & (dom D2)] =1 pred0
    -> ecnorm (D1 + D2) = ecnorm D1 + ecnorm D2.
  Proof.
    move=> D12_nI; have/domD_perm_eq dom_permeq := D12_nI.
    have inD1E p: p \in dom D1 -> p \notin dom D2.
      move=> p_in_D1; move/(_ p): D12_nI; rewrite !inE p_in_D1.
      by rewrite andTb => /= ->.
    have inD2E p: p \in dom D2 -> p \notin dom D1.
      move=> p_in_D2; move/(_ p): D12_nI; rewrite !inE p_in_D2.
      by rewrite andbT => /= ->.
    rewrite ecnormE (eq_big_perm _ dom_permeq) /=.
    rewrite big_cat /= big_seq_cond [X in _ + X]big_seq_cond.
    rewrite (eq_bigr (fun p => `|coeff p D1| )); last first.
      move=> p /andP [/inD1E p_notin_D2 _]; rewrite coeffD.
      by rewrite [X in _ + X]coeff_outdom // addr0.
    rewrite [X in _ + X](eq_bigr (fun p => `|coeff p D2| )); last first.
      move=> p /andP [/inD2E p_notin_D1 _]; rewrite coeffD.
      by rewrite [X in X + _]coeff_outdom // add0r.
    by rewrite -!big_seq_cond -!ecnormE.
  Qed.

  Lemma ecnorm_ge0 D: 0 <= ecnorm D.
  Proof. by rewrite ecnormE; apply: sumr_ge0=> i _; rewrite normrE. Qed.

  Lemma norm_eq0P(D : {freeg (point K)}):
    ecnorm D = 0 -> D = << deg D *g ∞ >>.
  Proof.
    move=> nmD_eq0; have: D = << coeff ∞ D *g ∞ >>.
      rewrite {1}[D]div_sumE -[X in _ = X]addr0; congr (_ + _).
      rewrite big_seq_cond big1 // => p /andP [p_in_D nz_p].
      move/eqP: nmD_eq0; rewrite ecnormE psumr_eq0; last first.
        by move=> i _; rewrite normrE.
      move/allP/(_ p p_in_D)/implyP/(_ nz_p); rewrite normr_eq0.
      by move/eqP=> ->; rewrite freegU0.
    by move=> ED; rewrite ED degU.
  Qed.

  Lemma norm_eq1P (D : {freeg (point K)}):
    ecnorm D = 1 ->
      exists2 p, (p != ∞) &
        exists b : bool, exists n,
          D = << p >> *~ ((-1) ^+ b) + << n *g ∞ >>.
  Proof.
    move=> nD_eq1; have: forall p, p != ∞ -> `|coeff p D| <= 1.
      move=> p nz_p; rewrite lerNgt; apply/negP => NDp_gt1.
      move: nD_eq1; rewrite ecnormE (big_rem p) /=; last first.
        by rewrite mem_dom inE -normr_eq0 neqr_lt (ltr_trans ltr01).
      move/eqP; rewrite nz_p eqr_le => /andP [h _]; move: h.
      set s := \sum_(_ <- _ | _) _; have: 0 <= s.
        by apply/sumr_ge0=> i _; rewrite normr_ge0.
      by move/(ltr_le_add NDp_gt1); rewrite addr0 ltrNge=> /negbTE->.
    move=> NDp_le1; move: nD_eq1; rewrite ecnormE -big_filter.
    rewrite {3}[D]div_sumE -[X in _ + X]big_filter; set s := [seq _ <- _ | _].
    case sE: s => [|p ps]; first by rewrite big_nil.
    have: p \in s by rewrite sE inE eqxx.
    rewrite /s mem_filter=> /andP [nz_p p_in_D].
    rewrite !big_cons; have cpD: `|coeff p D| = 1.
      apply/eqP; rewrite eqr_le NDp_le1 ?andTb //.
      by have := p_in_D; rewrite -gtz0_ge1 normrE mem_dom inE.
    rewrite cpD -{2}[1]addr0 => /addrI=> sum_ps_eq0; exists p=> //.
    exists (coeff p D < 0); exists (coeff ∞ D); rewrite addrC.
    congr (_ + _); rewrite freegU_mulz -[X in _ = X]addr0.
    congr (_ + _); last first.
      rewrite big_seq big1 // => i i_in_ps; apply/eqP.
      rewrite freegU_eq0; move/eqP: sum_ps_eq0.
      rewrite psumr_eq0; last by move=> ? _; rewrite normrE.
      by move/allP/(_ i i_in_ps)/implyP; rewrite normr_eq0; apply.
    by rewrite -{1}[coeff p D]mulr_sign_norm cpD mulr1 intz.
  Qed.

  Lemma norm_eq1P_deg (D : {freeg (point K)}):
    ecnorm D = 1 ->
      exists2 p, (p != ∞) &
        exists b : bool,
          D = << p >> *~ ((-1) ^+ b) + << (deg D) - (-1) ^+ b *g ∞ >>.
  Proof.
    move/norm_eq1P; case=> p nz_p [b [n DE]]; exists p=> //; exists b.
    have/(congr1 (@deg _)) := DE; rewrite degD raddfMz /= !degU.
    by move=> ->; rewrite addrAC intr_sign subrr add0r.
  Qed.
End ECDiv.


Require Export kat_alph atoms gl kat kat_pdrvs wf_extra symbs kat_dec.

Module PHL1.
  Module ExAlph.
    Definition ntests := 4.
  End ExAlph.

  Module teste1 := KATDec(ExAlph).
  Export teste1.

  Definition t0 := baV (Ord (ntests) 0 (refl_equal (ltb 0 (ntests)))).
  Definition t1 := baV (Ord (ntests) 1 (refl_equal (ltb 1 (ntests)))).
  Definition t2 := baV (Ord (ntests) 2 (refl_equal (ltb 2 (ntests)))).
  Definition t3 := baV (Ord (ntests) 3 (refl_equal (ltb 3 (ntests)))).

  Definition u := (`1 + `2)#.
  Definition r := ([t0]?*[!t1]? + [t1]?*`1*[!t2]? + [t2]?*`2*[!t3]?)#.
  Definition p := [t0]?*[t3]?*`1*[t1]?*`2*[!t2]?.

  Goal p + u*r*u == [ba0]? + u*r*u.
  Time dec_re.
  Qed.
End PHL1.

Module PHL2.
  Module ExAlph.
    Definition ntests := 6.
  End ExAlph.

  Module teste := KATDec(ExAlph).
  Export teste.

  Definition t0 := baV (Ord (ntests) 0 (refl_equal (ltb 0 (ntests)))).
  Definition t1 := baV (Ord (ntests) 1 (refl_equal (ltb 1 (ntests)))).
  Definition t2 := baV (Ord (ntests) 2 (refl_equal (ltb 2 (ntests)))).
  Definition t3 := baV (Ord (ntests) 3 (refl_equal (ltb 3 (ntests)))).
  Definition t4 := baV (Ord (ntests) 4 (refl_equal (ltb 4 (ntests)))).
  Definition t5 := baV (Ord (ntests) 5 (refl_equal (ltb 5 (ntests)))).

  Definition u := (`1 + `2 + `3 + `4)#.
  Definition r := ([t0]?*`1*[!t1]? + [t1]?*`2*[!t2]? + [t3]?*[t2]?*`3*[!t4]? + [t4]?*`2*[!t2]?
                   + [t2]?*[!t3]?*[!t5]?)#.
  Definition p := [t0]?*`1*[t1]?*`2*[t2]?*([t3]?*[t2]?*`3*[t4]?*`4)#*[!(t3 `+ t5)]?.

  Goal p + u*r*u == [ba0]? + u*r*u.
  Time dec_re.
  Qed.
End PHL2.