(* Require Import RamifyCoq.graph.find_not_in.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.reachable_ind. *)
Require Import Coq.Logic.ProofIrrelevance.
Require Import RamifyCoq.lib.Ensembles_ext.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.relation_list.
Require Import RamifyCoq.lib.Equivalence_ext.

Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Relations.Relation_Definitions.

Require Import  Coq.omega.Omega.
Require Import Coq.Logic.Classical.

Arguments clos_refl_trans {A} _ _ _.
Arguments clos_refl_trans_1n {A} _ _ _.
Arguments clos_refl_trans_n1 {A} _ _ _.

Definition V:=nat.
Definition E := (V * V)%type.

Definition E_eqb (u v : E) : bool :=
match Nat.eqb (fst u) (fst v) with
|true  =>  Nat.eqb (snd u) (snd v)
|false => false
end.
Theorem E_eqb_relf : forall u , E_eqb u u = true.
Proof.
  intros. destruct u. unfold E_eqb. rewrite Nat.eqb_refl. rewrite Nat.eqb_refl. auto.
Qed.

Theorem E_eqb_eq : forall u v , E_eqb u v = true <-> u= v.
Proof.
  intros.
  split. intros.
  destruct u . destruct v. unfold E_eqb in H. simpl in H.
  remember (v0=?v) as s.
  destruct s. symmetry in Heqs.  apply Nat.eqb_eq in Heqs.
  apply Nat.eqb_eq in H. subst. auto. inversion H.
  intros. subst. apply E_eqb_relf.
Qed.

Record BiGraph := {
  Vlist : list V;
  Elist : list E;
  vvalid : V -> Prop := fun x => In x Vlist;
  evalid : E -> Prop := fun e => In e Elist;
  src : E -> V := fun e => fst e;
  dst : E -> V := fun e => snd e;
  eo: E -> E := fun e => (snd e, fst e);
  f : V -> bool ; (* 表示两个点集 *)
  re : forall e x y, evalid e -> src e = x -> dst e = y -> f x = negb (f y);
  re_a : forall e,  In (eo e) Elist ;
  (**每两个点之间连两条边*)
}.

Fixpoint con_pre  (all_e: list E) (v: V) : list V :=
match all_e with
|nil => nil
|e::all_e' => if (Nat.eqb (fst e) v) then (snd e)::con_pre all_e' v
    else con_pre all_e' v
end.

Definition disjoint_edges (e1 e2 : E) : Prop :=
  ((fst e1) <> (fst e2)) /\ ((fst e1) <> (snd e2)) /\ ((snd e1) <> (fst e2)) /\ ((snd e1) <> (snd e2)).

Definition disjoint_edges_set (b:BiGraph)(l:list E) : Prop :=
  forall e1 e2: E,
  In e1 l -> In e2 l -> e1 <> e2 -> e1 <> (eo b e2) ->  disjoint_edges e1 e2.

Fixpoint remove_e (x : E) (l : list E) : list E :=
    match l with
      |nil => nil
      | y::tl => if (E_eqb x y) then remove_e x tl else y::(remove_e x tl)
    end.

Theorem remove_e_In : forall l x , ~ In x (remove_e x l).
Proof.
  intros.
  induction l.
  - simpl. auto.
  - simpl. remember (E_eqb x a ) as s. destruct s. auto.
    unfold In. unfold not. intros. destruct H. rewrite H in Heqs. destruct x.
    unfold E_eqb in Heqs. simpl in Heqs. rewrite Nat.eqb_refl in Heqs.
    rewrite Nat.eqb_refl in Heqs. inversion Heqs. unfold not in IHl. apply IHl. auto.
Qed.

Theorem remove_length_not : forall x l , ~ In x l  ->
       length l = length (remove_e x l).
Proof.
  induction l; intros.
  auto.
  simpl.
  simpl in H.
  apply not_or_and in H.
  destruct H.
  apply not_eq_sym in H.
  rewrite <- E_eqb_eq in H.
  apply Bool.not_true_is_false in H.
  rewrite H.
  apply IHl in H0.
  simpl.
  auto.
Qed.

Theorem remove_length_in : forall x l , In x l  ->
       S (length (remove_e x l)) <= length(l).
Proof.
  induction l; intros.
  destruct H.
  simpl.
  remember (E_eqb x a).
  destruct b.
  pose proof classic (In x l).
  destruct H0.
  apply IHl in H0.
  auto.
  rewrite (remove_length_not x l H0).
  auto.
  destruct H.
  Search (E_eqb _ _ = true).
  apply eq_sym in H.
  rewrite <- E_eqb_eq in H.
  rewrite H in Heqb.
  inversion Heqb.
  apply IHl in H.
  simpl.
  apply Peano.le_n_S.
  exact H.
Qed.

Fixpoint list_sub (u v :list V) : list V :=
match v with
|nil => u
|e::v' => list_sub (remove Nat.eq_dec e u ) v'
end.

Fixpoint list_sub_e (u v :list E) : list E :=
match v with
|nil => u
|e::v' => list_sub_e (remove_e  e u ) v'
end.

Fixpoint e_to_v' (g : BiGraph) (p : list E) {struct p} :
  list V :=
  match p with
  | nil => nil
  | e :: nil =>
      src g e :: dst g e :: nil
  | e :: (_ :: _) as el =>
      src g e :: e_to_v' g el
  end.

Fixpoint e_to_vth (g: BiGraph) (p : list E) {struct p} : list V :=
  match p with
  | nil => nil
  | e :: nil => dst g e :: src g e :: nil
  | e :: el => dst g e :: e_to_v' g el
  end.

Fixpoint Inb (x: V) (l : list V) : bool :=
match l with
|nil => false
|y::l' => if  Nat.eqb x y then true else (Inb x l')
end.

Fixpoint Inb_e (x :E ) (l:list E): bool :=
match l with
|nil => false
|y::l' => if  E_eqb  x y then true else (Inb_e x l')
end.

Theorem Inb_e_In: forall l x , Inb_e x l = true <-> In x l.
Proof.
  intros. induction l. - simpl. split. intros. inversion H. intros.  inversion H.
  - simpl. remember (E_eqb x a) as s. destruct s. symmetry in Heqs.
    rewrite E_eqb_eq in Heqs.  split. intros. left. auto. intros. auto.
    split. intros. right. rewrite <- IHl. auto.
    intros. destruct H.  symmetry in H. rewrite <- E_eqb_eq in H. rewrite H in Heqs.
    inversion Heqs. apply IHl. auto.
Qed.

Definition Vstateb:= V -> bool.
Definition default_Vstateb : Vstateb := (fun _ => false).
Definition Vstateb_update (m : Vstateb) (v: V) : Vstateb :=
 fun x =>   if Nat.eqb x  v then true else m x.
Definition Vstateb_update_f (m : Vstateb) (v: V) : Vstateb :=
 fun x =>  if Nat.eqb x  v then false else m x.

Definition Vstateb_update_l (m : Vstateb) (v : list V) : Vstateb :=
 fun x => if Inb x v then true else m x.
Definition Vstateb_update_fl (m : Vstateb) (v : list V) : Vstateb :=
 fun x => if Inb x v then false else m x .

Definition Vstateb_update_op (m : Vstateb) (v : option V) : Vstateb :=
fun x => match v with
       |None => m x
       |Some y => Vstateb_update m y  x
       end.
(* Definition Vstate:= V -> Prop.
Definition default_Vstate : Vstate := (fun _ => False).
Definition Vstate_update (m : Vstate) (v: V) : Vstate :=
 fun x =>   x =  v \/ m x.
Definition Vstate_update_f (m : Vstate) (v: V) : Vstate :=
 fun x =>  ( x = v -> False ) \/ (~ x = v  -> m x).

Definition Vstate_update_l (m : Vstate) (v : list V) : Vstate :=
 fun x => In x v \/ m x.

Definition Vstate_update_fl (m : Vstate) (v : list V) : Vstate :=
 fun x => (In x v -> False ) \/ (~ In  x  v  -> m x).
 *)

(*
(*以下都是对于图 BG 而言*)
Context {BG: BiGraph}.

(**下面是关于  匹配 的定义 *)
Definition matching := list E.
(**
里面的边不相交
每一对匹配点之间都连接了两条有向边
*)

Definition is_matching (m: list E): Prop :=
disjoint_edges_set BG m /\ forall e, In e m -> In (eo BG e) m /\ In e (Elist BG).

Fixpoint Ma (v : V) (M :matching): (option V) :=
match M with
|nil => None (**该点为非匹配点*)
|e::m' => if Nat.eqb (src BG e) v then
          Some (dst BG e) else
            (Ma v m')
end.

(**定义了一个通用的matching*)
Context {M : matching}.
Hypothesis base_Match_re : is_matching M.

Definition Matching (v: V) : (option V) := Ma v M. (*对于一个点找到M中它的匹配点*)

(*  下面给出图的点集 边集和 某个点的连接点集 *)

Inductive step  : V -> V -> Prop :=
|step_intro : forall e  x y ,
                 evalid BG e ->
                 src BG e = x ->
                 dst BG e = y -> step  x y.

Definition connected (v: V) (cl : list V) : Prop :=
  forall (x : V ),  step  v x <-> In x cl.

Definition  LV:= Vlist BG.
Definition LE:=Elist BG.

Definition get_connectednode_func  := V -> list V.

Definition con : V -> list V := con_pre LE.

Hypothesis conlistre : forall v , connected v (con v).

Definition Max := length(LV).

(* 找到对于一个Vstateb中从大到小的第一个没有被访问过的*)

Fixpoint conn (v: V) (v1 : Vstateb) (n:nat): V :=
match n with
|O => O
|S n' =>  if Inb (S n') (con v) then
             (if v1 (S n') then n else conn v v1 n')
             else conn v v1 n'
end.

Definition max_conn (v : V) (v1 : Vstateb) := conn v v1 Max.

(*路径的定义*)
Definition e_to_v (p : list E) : list V := e_to_vth BG p .

Definition path : Type := (V * list E)%type.

(**小步语义*)
Inductive cross_step : (Vstateb * path) -> (Vstateb * path ) -> Prop :=
| one_v : forall (u w: V ) (e1 e2 : E) (v1 : Vstateb) ,
    Matching u  = None -> let v := max_conn u v1  in
    src BG e1 = u -> dst BG e1 = v  ->src BG e2 = v -> dst BG e2 = w ->~ In e1 M ->  In e2 M ->
    (*-> Matching v = Some w -> *)
         cross_step (Vstateb_update default_Vstateb u, (u, nil)) ( Vstateb_update (Vstateb_update (Vstateb_update default_Vstateb u)  v) w  , (w ,e2 :: (e1::nil)))
(**从一个非匹配点 经过非匹配边和匹配边  到一个匹配点 *)
| not_one : forall (u  w: V ) (e1 e2 e3 : E)(p :list E) (v1: Vstateb), (* ???  *)
    dst BG e3 = u -> In e3 M -> let v := max_conn u v1 in
    (* Nat.odd (length p) = true ->*)
    v1 u = true -> v1 w = false  ->
    src BG e1 = u -> dst BG e1 = v  -> src BG e2 = v -> dst BG e2 = w -> In e2 M -> ~ In e1 M
    ->(*->
      Matching v = Some w -> *)
         cross_step (v1, (u, e3 :: p)) ( Vstateb_update (Vstateb_update v1  v) w  , (w ,e2::(e1::(e3::p))))
(**从一个匹配点 经过非匹配边和匹配边  到一个匹配点 *)
|yes_to_no : forall (u v : V ) (e1 e2 : E) (p: list E)  (v1 : Vstateb) ,
   dst BG e2 = u ->  In e2 M -> v1 u = true -> let v := max_conn u v1 in
   Matching v = None ->
   src BG e1 = u -> dst BG e1 = v  -> ~ In e1 M ->
         cross_step (v1, (u, e2::p)) ( Vstateb_update v1  v , (v ,e1::(e2::p)))
(**从一个匹配点到非匹配点*)
|no_to_no :  forall (u : V ) (e1 :E)  ,
    Matching u  = None -> let v := max_conn u  (Vstateb_update default_Vstateb u) in
    Matching v = None ->
    src BG e1 = u -> dst BG e1 = v  -> ~ In e1 M ->
         cross_step (Vstateb_update default_Vstateb u, (u, nil))
         (Vstateb_update (Vstateb_update default_Vstateb u) v,(v, e1 :: nil) )
(* *)
|Back_to_yes : forall (u w1 w2: V ) (e1 e2 e3: E)(p :list E)
               (v1: Vstateb),
      dst BG e3 = w2 -> In e3 M ->
      v1 u = true -> max_conn u v1 = O ->
            In e1 M ->  ~In e2 M ->
              src BG e1 = w1 -> dst BG e1 = u  -> src BG e2 = w2 -> dst BG e2 = w1 ->
           cross_step (v1, (u, e1::(e2::(e3::p)))) ( Vstateb_update_fl v1 (list_sub (con u) (e_to_v p) ) , (w2 ,e3::p))
(**回溯到上一个匹配点*)
|Back_to_no : forall (u w1 w2 : V) (e1 e2 : E) (p : list E )
              (v1 : Vstateb) ,
     v1 u = true -> max_conn u v1 = O ->
           In e1 M ->  ~In e2 M ->
             src BG e1 = w1 -> dst BG e1 = u  -> src BG e2 = w2 -> dst BG e2 = w1 ->
           cross_step (v1, (u, e1::(e2::nil))) ( Vstateb_update_fl v1 (list_sub (con u )(e_to_v p) ) , (w2 ,nil))
(** 回溯到初始状态即一个点*)    .

Inductive cross_halt : (Vstateb * path) -> Prop :=
|success : forall (u : V) (v : Vstateb) (e : E )(p : list E),
              Matching u = None ->
            v u = true -> dst BG e = u -> ~ In e M -> cross_halt (v , (u, e::p)).
Definition state := (Vstateb * path)%type.
Definition multi_cstep : state -> state -> Prop := clos_refl_trans cross_step .

Lemma half_halt :
  forall st1 st2, cross_step st1 st2 -> ~ cross_halt st1.
Proof.
  intros.
  unfold not; intros; inversion H.
  - rewrite <- H8 in H0.
    inversion H0.
  - rewrite <- H11 in H0.
    inversion H0. subst. auto.
  - rewrite <- H8 in H0.
    inversion H0. subst. auto.
  - rewrite <- H6 in H0.
    inversion H0.
  - rewrite <- H11 in H0.
    inversion H0. subst. auto.
  - rewrite <- H9 in H0.
    inversion H0. subst. auto.
Qed.

Lemma stay_even :
  forall st1 st2, cross_step st1 st2 -> ~cross_halt st2 ->
    Nat.even (length (snd (snd st1))) = Nat.even (length (snd (snd st2))).
Proof.
  intros.
  induction H.
  - simpl. reflexivity.
  - unfold snd. reflexivity.
  - unfold not in H0. destruct H0. apply success.
    auto.  unfold Vstateb_update.
    assert (Nat.eqb v0 v0 = true).
    apply PeanoNat.Nat.eqb_refl.
    rewrite H0. reflexivity.
    auto. auto.
  - unfold not in H0. destruct H0. apply success.
    auto. unfold Vstateb_update at 1.
    assert (Nat.eqb v v = true).
    apply PeanoNat.Nat.eqb_refl.
    rewrite H0. reflexivity.
    auto. auto.
  - unfold snd. reflexivity.
  - unfold snd. reflexivity.
Qed.

Theorem try :
  forall  ( v: V) st , ~ cross_halt st ->
    multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
      Nat.even (length (snd (snd st))) = true.
Proof.
  intros.
  apply Operators_Properties.clos_rt_rtn1_iff in H0.
  induction H0.
  - reflexivity.
  - pose proof (half_halt y z H0) .
    pose proof (IHclos_refl_trans_n1 H2).
    rewrite <- H3.
    apply eq_sym.
    apply stay_even; auto.
Qed.

Lemma cons_length : forall (v: E) l , length (v::l) = S (length l).
Proof.
  intros.
  induction l.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.
Lemma S_even : forall n , Nat.even (S n) = negb (Nat.even n).
Proof.
  intros.
  induction n.
  - simpl. reflexivity.
  - rewrite IHn. simpl. rewrite Bool.negb_involutive. reflexivity.
Qed.
Lemma list_ode: forall (v: E) l,  Nat.even (length l) =Nat.odd (length ( v:: l)).
Proof.
 intros. revert v.
 induction l.
 - simpl. reflexivity.
 - unfold Nat.odd. rewrite cons_length. intros. rewrite cons_length.
   rewrite S_even. rewrite S_even. rewrite Bool.negb_involutive.
   unfold Nat.odd in IHl. rewrite (IHl a). apply Bool.negb_involutive.
Qed.

Lemma notmatching : forall v e M, src BG e = v ->
     In e M -> ~ Ma v M = None .
Proof.
  intros.
  unfold not.
  intros. induction M0.
  - inversion H0.
  - inversion H0. rewrite H2 in H1. rewrite <- H in H1. simpl in H1.
    rewrite PeanoNat.Nat.eqb_refl in H1. inversion H1.
    simpl in H1. destruct (Nat.eqb (src BG a) v). inversion H1. apply IHM0. auto. auto.
Qed.

Lemma notmatching_rev : forall v e M, src BG e = v ->
      Ma v M = None -> ~ In e M .
Proof.
  intros.
  unfold not.
  intros. induction M0.
  - inversion H1.
  - inversion H1. rewrite H2 in H0. rewrite <- H in H0. simpl in H0.
    rewrite PeanoNat.Nat.eqb_refl in H0. inversion H0.
    simpl in H0. destruct (Nat.eqb (src BG a) v). inversion H0. apply IHM0. auto. auto.
Qed.

Lemma change_even :
  forall st1 st2, cross_step st1 st2 -> cross_halt st2 ->
    Nat.even (length (snd (snd st1))) = Nat.odd (length (snd (snd st2))).
Proof.
  intros.
  induction H.
  - inversion H0. unfold not in H14. apply H14 in H6.  inversion H6.
  - inversion H0. unfold not in H17. apply H17 in H8.  inversion H8.
  - unfold snd . pose proof (list_ode e1 (e2 :: p)). apply H7.
  - unfold snd. apply list_ode.
  - inversion H0. unfold not in H17. apply H17 in H1.  inversion H1.
  - inversion H0.
Qed.

Theorem path_odevity :
 forall v st, cross_halt st ->
      multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
      Nat.odd (length (snd (snd st))) = true.
Proof.
 intros.
 apply Operators_Properties.clos_rt_rtn1_iff in H0.
 induction H0.
 - inversion H.
 - pose proof (half_halt y z H0).
   assert ( multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) y).
   unfold multi_cstep. apply Operators_Properties.clos_rt_rtn1_iff. apply H1.
   pose proof (try v y H2 H3).
   pose proof (change_even y z H0 H). rewrite H5 in H4. auto.
Qed.

Variable de : E.

(**定义
  交错路
  增广路*)
Fixpoint cross_path (l: list E) : Prop :=
match l with
|nil => True
|m::nil => True
|m::l' => (* actually hd de l' 不会需要default值*)
             ( In m M /\ ~ In (hd de l') M  \/
                   ~ In m M /\  In (hd de l') M)
             /\ cross_path l'
end.

Definition aug_path (l: list E) : Prop :=
match l with
|nil => False
|m::nil => ~ In m M
|m::n::l' => (~ In m M /\ In n M )/\
          (cross_path l' /\ cross_path (n::l'))
end.

Lemma cross_stay_unit : forall y z ,
   cross_step y z ->
       cross_path (snd (snd y)) -> cross_path (snd (snd z)).
Proof.
  intros.
  induction H.
  - simpl. split. 2: auto.  left. split. auto.
    pose proof ( notmatching_rev u e1 M). apply H7. auto. auto.
  - split. auto. unfold snd in H0. split. auto. auto.
  - unfold snd. unfold snd in H0. split. auto. auto.
  - unfold snd. unfold snd in H0. reflexivity.
  - unfold snd. unfold snd in H0. destruct H0. destruct H10. auto.
  - unfold snd. reflexivity.
Qed.

Theorem cross_stay :
  forall st1 st2, cross_path (snd (snd st1)) ->
      multi_cstep  st1  st2 ->
      cross_path (snd (snd st2)).
Proof.
 intros.
 apply Operators_Properties.clos_rt_rtn1_iff in H0.
 induction H0.
 - unfold snd. auto.
 - pose proof ( cross_stay_unit y z  H0 IHclos_refl_trans_n1 ). auto.
Qed.

Lemma cross_start_simpl :
 forall  v st,
    multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
    cross_path (snd (snd st)).
Proof.
  intros.
  assert (cross_path (snd (snd
            (Vstateb_update default_Vstateb v, (v, nil))))).
  unfold snd. reflexivity.
  eapply cross_stay. apply H0. auto.
Qed.

Lemma  first_match: forall v y ,
     cross_step (Vstateb_update default_Vstateb v, (v, nil)) y ->
       ~ In (last (snd (snd y)) de) M.
Proof.
  intros.
  inversion H.
  - unfold snd. unfold last. auto.
  - unfold snd. unfold last. auto.
Qed.

Lemma  path_stay_unit: forall x y,
      ~ (snd (snd x)) = nil -> ~ (snd (snd y)) = nil ->
       cross_step x y -> ~ In (last (snd (snd x)) de) M ->
               ~ In (last (snd (snd y)) de) M.
Proof.
  intros.
  unfold not. intros.
  inversion H1.
  - subst. unfold snd in H. unfold not in H. apply H. auto.
  - subst. unfold snd in H0. unfold snd in H3. unfold snd in H2.
    simpl in H3. simpl in H2. unfold not in H2. apply H2. apply H3.
  - subst. unfold snd in H0. unfold snd in H3. unfold snd in H2.
    unfold not in H2. apply H2. simpl in H3. simpl. apply H3.
  - subst. unfold snd in H. unfold not in H. apply H. auto.
  - subst.  unfold snd in H0. unfold snd in H3. unfold snd in H2.
    unfold not in H2. apply H2. simpl in H3. simpl. apply H3.
  -  subst. unfold snd in H0. unfold not in H0. apply H0. auto.
Qed.

Theorem path_stay : forall x y,
    ~ (snd (snd x)) = nil -> ~ (snd (snd y)) = nil ->
       multi_cstep x y -> ~ In (last (snd (snd x)) de) M ->
               ~ In (last (snd (snd y)) de) M.
Proof.
  intros.
  apply Operators_Properties.clos_rt_rtn1_iff in H1.
  induction H1.
  - auto.
  - inversion H1.
    eapply first_match. rewrite <- H11 in H1. rewrite H12.  apply H1.
    eapply path_stay_unit. 3: rewrite H15; apply H1.  rewrite <- H14.
    simpl. unfold not. intros. inversion H16. unfold snd.
    unfold not. intros. inversion H16. rewrite <- H14. unfold snd.
    rewrite <- H14 in IHclos_refl_trans_n1.
    unfold snd in IHclos_refl_trans_n1. apply IHclos_refl_trans_n1.
    unfold not. intros. inversion H16.
    unfold snd. rewrite <- H11 in IHclos_refl_trans_n1.
    unfold snd in IHclos_refl_trans_n1.
    unfold last. unfold last in IHclos_refl_trans_n1.
    apply IHclos_refl_trans_n1. unfold not. intros. inversion H13.
    unfold snd. unfold last. auto.
    unfold snd. rewrite <- H14 in IHclos_refl_trans_n1.
    unfold snd in IHclos_refl_trans_n1.
    unfold last. unfold last in IHclos_refl_trans_n1.
    apply IHclos_refl_trans_n1. unfold not. intros. inversion H16.
    rewrite <- H13 in H0. unfold not in H0. unfold not. intros.
    apply H0. auto.
Qed.

Lemma cross_start_pre:
  forall v st, ~ (snd (snd st)) = nil ->
     multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
       ~ In (last (snd (snd st)) de) M.
Proof.
  intros.
  apply Operators_Properties.clos_rt_rt1n_iff in H0.
  inversion H0.
  - subst.  unfold snd in H. unfold not in  H. auto.
  - pose proof (path_stay y z).
    subst.
    apply H4.
      inversion H1. unfold snd. unfold not.  intros.
    inversion H14. unfold snd. unfold not.  intros.
    inversion H12.
      auto.
      apply Operators_Properties.clos_rt_rt1n_iff . auto.
      eapply first_match. apply H1.
Qed.

Theorem cross_start:
  forall v st, cross_halt st ->
     multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
       ~ In (last (snd (snd st)) de) M.
Proof.
  intros.
  eapply cross_start_pre.
  2: apply H0.
  inversion H. unfold snd. unfold not. intros. inversion H6.
Qed.

Lemma path_first_decide : forall p,
  cross_path p -> ~ In (last p de) M -> 1 <= length p ->
    ( Nat.odd (length p)=true  /\   ~ In (hd de p) M ) \/
      (Nat.odd (length p) = false /\  In (hd de p) M).
Proof.
  intros.
  induction p.
  - inversion H1.
  - destruct p.
    + left. simpl in H0. simpl. auto.
    + simpl. destruct H. unfold last in IHp. unfold last in H0.
      pose proof (IHp H2 H0 ). simpl in H3. assert( 1<= S(length p)).
      omega. apply H3 in H4. unfold hd in H. destruct H4.
        destruct H4. right. split. unfold Nat.odd. rewrite S_even.
        rewrite Bool.negb_involutive. unfold Nat.odd in H4.
        rewrite Bool.negb_true_iff in H4. auto.
        destruct H. destruct H. auto. destruct H. unfold not in H5.
        apply H5 in H6. inversion H6.
        destruct H4.
        left. split. unfold Nat.odd. rewrite S_even.
        rewrite Bool.negb_involutive. unfold Nat.odd in H4.
        rewrite Bool.negb_false_iff in H4. auto.
        destruct H. destruct H. unfold not in H6.
        apply H6 in H5. inversion H5. destruct H.
        auto.
Qed.

Lemma st_ed_unmatched:
  forall (p: list E) (v: V) st, aug_path p -> cross_halt st -> multi_cstep (Vstateb_update default_Vstateb v, (v, nil)) st -> Matching (fst (snd st)) = None.
Proof.
  intros.
  apply Operators_Properties.clos_rt_rtn1_iff in H1.
  induction H1.
  inversion H0.
  inversion H0.
  unfold snd.
  unfold fst.
  exact H3.
Qed.

Lemma path_to_aug : forall p ,
    cross_path p ->  ~ In (last p de) M ->
      Nat.odd (length p) = true  ->
          aug_path p.
Proof.
 intros.
 induction p.
 - inversion H1.
 - destruct p.
   simpl. simpl in H1. auto. assert (1<= length((a :: e :: p))).
   simpl. omega. assert (1<= length (e::p)). simpl. omega.
   pose proof (path_first_decide (a::e::p) H H0 H2). destruct H.
   assert ( ~ In (last (e::p) de) M). unfold last. unfold last in H0.
   auto.
   pose proof (path_first_decide (e::p) H5 H6 H3).
   split.
   destruct H4. destruct H4. unfold hd in H8. split. auto.
     destruct H7. destruct H7. unfold Nat.odd in H7.
     unfold Nat.odd in H4. simpl in H4. rewrite Bool.negb_true_iff in H4.
     rewrite Bool.negb_true_iff in H7. assert (length(e::p) = S(length p)).
     reflexivity. rewrite H10 in H7. rewrite S_even in H7.
     rewrite Bool.negb_false_iff in H7. rewrite H4 in H7. inversion H7.
     destruct H7. unfold hd in H9. auto.
     destruct H4. rewrite H4 in H1. inversion H1.
   split. 2: auto.
   destruct p.
   + reflexivity.
   + destruct H5. auto.
Qed.

(**终极定理： 小步得到的确实是 增广路径！*)
Theorem step_to_aug: forall v st, cross_halt st ->
     multi_cstep ( Vstateb_update default_Vstateb v, (v, nil)) st ->
       aug_path (snd (snd st)) .
Proof.
  intros.
  eapply (path_to_aug (snd (snd st))).
  eapply cross_stay. 2: apply H0. reflexivity.
  eapply cross_start. auto. apply H0.
  eapply path_odevity. auto. apply H0.
Qed.

Definition xor_edge (e1 p: list E) : list E :=
  list_sub_e e1 p ++ list_sub_e p e1.

(*证明：根据aug_path得到的匹配确实更大*)
Theorem Bigger : forall p ,
 cross_path p ->
    length M   <= length (xor_edge M p).
Proof.
  intros.
  unfold xor_edge.
  rewrite app_length.
  induction p.
  - simpl. omega.
  - destruct p. simpl. simpl in IHp.
    pose proof classic (In a M). destruct H0.
    Admitted.

 *)

(* *)


Theorem simple : forall A, A -> A.
Proof.
auto.
Qed.


From mathcomp Require Import ssreflect ssrfun seq.
From rlzrs Require Import all_rlzrs choice_dict.
Require Import facts all_baire cs smod prod sub func classical_cont classical_mach Duop.
Require Import FunctionalExtensionality Classical.

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

Local Open Scope cs_scope.
Lemma ass_cont (X Y: cs) (f: X -> Y): f \from (codom (@associate X Y)) <-> f \is_continuous.
Proof.
  split => [[psi /=rlzr] | [F [rlzr cont]]]; first by exists \F_(U psi); split; last exact/FM_cont.
  have [psi val]:= (U_universal (someq X) (somea X) (fun _ => somea Y) (Q_count X) cont).
  by exists psi; exact/ntrvw.tight_rlzr/val.
Qed.

Definition exist_c (X Y: cs) (f: X -> Y) (cont: f \is_continuous): (X c-> Y).
Proof. by exists f; apply/ass_cont. Defined.

Lemma prod_uprp_cont (X Y Z: cs) (f: Z c-> X) (g: Z c-> Y):
  exists! (F: Z c-> (cs_prod X Y)),
    (forall z, (projT1 F z).1 = (projT1 f) z)
    /\
    (forall z, (projT1 F z).2 = (projT1 g) z).
Proof.
  set F :Z -> X \*_cs Y := (projT1 f **_f projT1 g) \o_f mf.diag.
  have Fcont: F \is_continuous.
  - exact/(cont_comp _ (facts.diag_cont Z))/fprd_cont/ass_cont/(projT2 g)/ass_cont/(projT2 f).
  exists (exist_c Fcont); split => // G [] eq eq'.
  apply/eq_sub/functional_extensionality => z; symmetry.
  exact/injective_projections/eq'/eq.
Qed.

Definition cs_comp (X Y Z: cs) (f: X c-> Y) (g: Y c-> Z): (X c-> Z).
Proof.
  exists ((projT1 g) \o_f projT1 f); apply/ass_cont/cont_comp.
  - exact/ass_cont/(projT2 g).
  exact/ass_cont/(projT2 f).
Defined.

Notation "g \o_cs f" := (cs_comp f g) (at level 29): cs_scope.

Lemma cs_comp_spec (X Y Z: cs)(f: X c-> Y) (g: Y c-> Z): projT1 (g \o_cs f) =1 (projT1 g \o_f projT1 f).
Proof. done. Qed.

Local Open Scope baire_scope.
Lemma eval_rlzr_cntop (X Y: cs):
  (@eval_rlzr (queries X) (queries Y) (answers X) (answers Y))|_(dom (rep (X c-> Y \*_cs X))) \is_continuous_operator.
Proof.
  rewrite !cont_spec => psiphi [Fpsiphi [[[f x] [psinf phinx]] /eval_rlzr_val val]].
  rewrite /= in psinf phinx; have phifd: (rprj psiphi) \from dom \F_(U (lprj psiphi)) by exists Fpsiphi.
  have [FqM [FsM prp]]:= @FM_cont_spec (queries X) (queries Y) (answers X) (answers Y).
  have [subs [subs' [c_prp _]]]:= prp (lprj psiphi) (rprj psiphi).
  have [qf qvl]:= subs (rprj psiphi) phifd.
  have [sf svl]:= subs' (rprj psiphi) phifd.
  move: subs subs' => _ _.
  have [qfmodF [qfmodqF _]]:= c_prp qf qvl.
  move: c_prp => _.
  exists (fun q' => map inl (sf q') ++ map inr (qf q')) => q'.
  exists (Fpsiphi q') => psi'phi' /coin_cat[coin coin'].
  have : (rprj psiphi) \and (rprj psi'phi') \coincide_on (qf q').
  - by elim: (qf q') coin' => // q K ih /= [eq /ih]; split; first rewrite /rprj eq.
  have: (lprj psiphi) \and (lprj psi'phi') \coincide_on (sf q').
  - by elim: (sf q') coin => // q K ih /= [eq /ih]; split; first rewrite /lprj eq.
  move: coin coin' => _ _ coin coin'.
  rewrite det_restr => [[[f' x'] [/=psi'nf' phi'nx']]] Fpsi'phi'/eval_rlzr_val val'.
  rewrite /= in psi'nf' phi'nx'; pose psiphi':= name_pair (lprj psiphi) (rprj psi'phi').
  have psiphi'nfx': psiphi' \describes (f, x') \wrt (X c-> Y \*_cs X).
  - by trivial.
  have [Fpsiphi' val'']: psiphi' \from dom eval_rlzr.
  - by have []:= eval_rlzr_crct psiphi'nfx'; first exact/F2MF_dom.
  have [a' tempcrt]:= qfmodF q'.
  have crt := crt_icf val tempcrt _; move: a' tempcrt => _ _.
  rewrite -(crt (rprj psi'phi') _ Fpsiphi' val''); last by apply/coin'.
  have [subs [subs' [cprp _]]]:= prp (lprj psiphi) (rprj psi'phi').
  have [ | qf' qvl']:= subs (rprj psi'phi'); first by exists Fpsiphi'.
  move: subs subs' => _ _.
  have [_ [_ qf'modsF]]:= cprp qf' qvl'.
  move: cprp => _.
  have mfeq: qf q' = qf' q'.
  - have [a' crt'] := qfmodqF q'.
    suff ->: qf' q' = a' by apply/crt'; first apply/coin_ref.
    by apply/crt'; first apply/coin'.
  have [_ [subs' [_ vprp]]]:= prp (lprj psiphi) (rprj psi'phi').
  have [ | sf' svl']:= subs' (rprj psi'phi'); first by exists Fpsiphi'.
  have [sfmodF _]:= vprp sf' svl'.
  move: vprp prp => _ _.
  have eq: sf q' = sf' q'.
  - have [a' crt']:= qf'modsF q'.
    have ->: sf' q' = a' by apply/crt'; first by rewrite -mfeq; apply/coin_ref.
    by apply/crt'; first by rewrite -mfeq; apply/coin_sym/coin'.
  have [a' crt']:= sfmodF q'.
  have ->: Fpsi'phi' q' = a' by apply/crt'; first by rewrite -eq; apply/coin.
  by symmetry; apply/crt'; first by rewrite -eq; apply/coin_ref.
Qed.
Local Close Scope baire_scope.

Lemma eval_cont (X Y: cs): (@evaluation X Y) \is_continuous.
Proof.
  exists (@eval_rlzr (queries X) (queries Y) (answers X) (answers Y))|_(dom (rep (X c-> Y \*_cs X))).
  split; last exact/eval_rlzr_cntop.
  rewrite rlzr_F2MF => psiphi fx psiphinfx.
  have [ | [Fpsiphi val] prp]:= eval_rlzr_crct psiphinfx; first exact/F2MF_dom.
  split => [ | Fq [_ val']]; first by exists Fpsiphi; split; first by exists fx.
  by have [f'x' [nm ->]]:= prp Fq val'.
Qed.

Definition pt_eval (X Y: cs) (x: X) (f: X c-> Y):= evaluation (f, x).

Lemma ptvl_val_cont (X Y: cs) (x: X): (@pt_eval X Y x) \is_continuous.
Proof.
  have [phi phinx]:= get_description x.
  exists (\F_(U (D phi))).
  rewrite rlzr_F2MF.
  split => [psi f psinf | ]; last exact/FM_cont.
  have [ | [Fphi /D_spec val] prp]:= psinf phi x phinx; first exact/F2MF_dom.
  split => [ | Fphi' /D_spec val']; first by exists Fphi.
  have [fa [Fphi'nfa]]:= prp Fphi' val'.
  by rewrite /pt_eval /evaluation => ->.
Qed.

Definition point_evaluation (X Y: cs) (x: X):= exist_c (@ptvl_val_cont X Y x).

Lemma ptvl_cont (X Y: cs): (@point_evaluation X Y) \is_continuous.
Proof.
  exists (F2MF (@D (queries X) (queries Y) (answers X) (answers Y))).
  rewrite F2MF_rlzr_F2MF; split => [phi x phinx psi f psinf _| ]; last first.
  - rewrite cont_F2MF; exact/D_cont.
  have [ | [Fphi /D_spec val] prp]:= psinf phi x phinx; first exact/F2MF_dom.
  split => [ | Fphi' /D_spec val']; first by exists (Fphi).
  have [fa [Fphinfa]]:= prp Fphi' val'.
  rewrite /point_evaluation/pt_eval/evaluation/= => ->.
  by exists fa.
Qed.


Require Import Coq.Program.Basics.
Require Import Clight.max.
Require Import VST.floyd.proofauto.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Open Scope program_scope.

Definition max_spec : ident * funspec :=
  DECLARE _max
    WITH n1 : Z, n2 : Z
    PRE [_n1 OF tint, _n2 OF tint]
      PROP(Int.min_signed <= n1 <= Int.max_signed;
           Int.min_signed <= n2 <= Int.max_signed)
      LOCAL(temp _n1 ((Vint ∘ Int.repr) n1);
            temp _n2 ((Vint ∘ Int.repr) n2))
      SEP()
    POST [ tint ]
      PROP()
      LOCAL(temp ret_temp ((Vint ∘ Int.repr) (Z.max n1 n2)))
      SEP().

Definition Gprog := ltac:(with_library prog [max_spec]).

Lemma body_max: semax_body Vprog Gprog f_max max_spec.
Proof.
  start_function.
  unfold compose in *; simpl.
  forward_if (
      PROP(Z.max n1 n2 = n1 \/ Z.max n1 n2 = n2)
      LOCAL(temp _res (Vint (Int.repr (Z.max n1 n2))))
      SEP()).
  1,2: forward; entailer!.
  rewrite Z.max_comm.
  unfold Z.max.
  apply Fcore_Zaux.Zcompare_Lt in H1.
  rewrite H1.
  auto.
  apply Z.ge_le in H1.
  rewrite Z.max_r.
  auto.
  assumption.
  Intros.
  forward.
Qed.


Definition dyslexic_imp := forall P Q:Prop, (P -> Q) -> Q -> P.

Definition dyslexic_contrap := forall P Q:Prop, (P -> Q) -> ~ P -> ~ Q.

Section dyslexia.
 Hypothesis d : dyslexic_imp.

 Theorem incons1 : False.
 Proof.
  now apply (d False True).
 Qed.

End dyslexia.

Section dyslexia2.
 Hypothesis s : dyslexic_contrap.

 Lemma incons2 : False.
 Proof.
  apply (s False True); [ | unfold not |];trivial.
 Qed.

End dyslexia2.


(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  under the terms of the GNU Lesser General Public License as    *)
(*  published by the Free Software Foundation, either version 2.1  *)
(*  of the License, or (at your option) any later version.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import ZArith.
Require Import List.
Require Import Bool.
Require Import Psatz.
Require Import Setoid Morphisms.

Require Import Misc.
Require Import Linalg.
Require Import Semantics.
Require Import Instr.

Open Scope Z_scope.
Open Scope list_scope.

(** * The semantics of polyhedral programs with schedules *)

Record Polyhedral_Instruction := {
  pi_instr : instr ;
  pi_poly : polyhedron ;
  pi_schedule : list (list Z * Z)%type ;
  pi_transformation : list (list Z * Z)%type ;
}.

Definition Poly_Program := list Polyhedral_Instruction.

Definition scanned to_scan n p m q := to_scan m q && negb (is_eq p q && (n =? m)%nat).
Hint Unfold scanned.

Instance scanned_proper : Proper ((eq ==> veq ==> eq) ==> eq ==> veq ==> (eq ==> veq ==> eq)) scanned.
Proof.
  intros to_scan1 to_scan2 Hto_scan n1 n2 Hn p1 p2 Hp m1 m2 Hm q1 q2 Hq.
  unfold scanned.
  erewrite Hto_scan by (exact Hm || exact Hq).
  rewrite Hn. rewrite Hm. rewrite Hp. rewrite Hq.
  reflexivity.
Qed.

Notation "'wf_scan'" := (Proper (eq ==> veq ==> eq)) (only parsing).

Inductive poly_semantics : (nat -> list Z -> bool) -> Poly_Program -> mem -> mem -> Prop :=
| PolyDone : forall to_scan prog mem, (forall n p, to_scan n p = false) -> poly_semantics to_scan prog mem mem
| PolyProgress : forall to_scan prog mem1 mem2 mem3 poly_instr n p,
    to_scan n p = true -> nth_error prog n = Some poly_instr ->
    (forall n2 p2 poly_instr2, nth_error prog n2 = Some poly_instr2 ->
                          lex_compare (affine_product poly_instr2.(pi_schedule) p2) (affine_product poly_instr.(pi_schedule) p) = Lt ->
                          to_scan n2 p2 = false) ->
    instr_semantics poly_instr.(pi_instr) (affine_product poly_instr.(pi_transformation) p) mem1 mem2 ->
    poly_semantics (scanned to_scan n p) prog mem2 mem3 ->
    poly_semantics to_scan prog mem1 mem3.

Theorem poly_semantics_extensionality :
  forall to_scan1 prog mem1 mem2,
    poly_semantics to_scan1 prog mem1 mem2 -> forall to_scan2, (forall n p, to_scan1 n p = to_scan2 n p) -> poly_semantics to_scan2 prog mem1 mem2.
Proof.
  intros to_scan1 prog mem1 mem2 Hsem.
  induction Hsem as [to_scan3 prog1 mem4 Hdone|to_scan3 prog1 mem3 mem4 mem5 pi n p Hscanp Heqpi Hts Hsem1 Hsem2 IH].
  - intros. constructor. intros. eauto.
  - intros to_scan2 Heq. econstructor; eauto. apply IH. intros. autounfold. rewrite Heq. auto.
Qed.

Lemma scanned_wf_compat :
  forall to_scan n p, wf_scan to_scan -> wf_scan (scanned to_scan n p).
Proof.
  intros to_scan n p Hwf. apply scanned_proper; [exact Hwf | reflexivity | reflexivity].
Qed.

Theorem poly_semantics_concat :
  forall to_scan1 prog mem1 mem2,
    poly_semantics to_scan1 prog mem1 mem2 ->
    forall to_scan2 mem3,
    wf_scan to_scan1 ->
    (forall n p, to_scan1 n p = false \/ to_scan2 n p = false) ->
    (forall n1 p1 pi1 n2 p2 pi2, nth_error prog n1 = Some pi1 -> nth_error prog n2 = Some pi2 ->
                           lex_compare (affine_product pi2.(pi_schedule) p2) (affine_product pi1.(pi_schedule) p1) = Lt ->
                           to_scan1 n1 p1 = false \/ to_scan2 n2 p2 = false) ->

    poly_semantics to_scan2 prog mem2 mem3 ->
    poly_semantics (fun n p => to_scan1 n p || to_scan2 n p) prog mem1 mem3.
Proof.
  intros to_scan1 prog mem1 mem2 Hsem.
  induction Hsem as [to_scan3 prog1 mem4 Hdone|to_scan3 prog1 mem4 mem5 mem6 pi n p Hscanp Heqpi Hts Hsem1 Hsem2 IH].
  - intros to_scan2 mem3 Hwf1 Hdisj Hcmp Hsem1. eapply poly_semantics_extensionality; eauto. intros. rewrite Hdone. auto.
  - intros to_scan2 mem3 Hwf1 Hdisj Hcmp Hsem3. eapply PolyProgress with (n := n) (p := p); eauto.
    + rewrite Hscanp. auto.
    + intros n2 p2 pi2 Heqpi2 Hts2.
      reflect; split.
      * apply (Hts n2 p2 pi2); auto.
      * destruct (Hcmp n p pi n2 p2 pi2) as [H | H]; auto; congruence.
    + eapply poly_semantics_extensionality; [apply IH|]; eauto.
      * apply scanned_wf_compat; auto.
      * intros n2 p2. autounfold. destruct (Hdisj n2 p2) as [H | H]; rewrite H; auto.
      * intros n1 p1 pi1 n2 p2 pi2 Heqpi1 Heqpi2 Hcmp1.
        destruct (Hcmp n1 p1 pi1 n2 p2 pi2) as [H | H]; autounfold; auto. rewrite H. simpl.
        destruct (is_eq p p1 && (n =? n1)%nat) eqn:Hd; simpl; auto.
      * intros n0 p0. autounfold. simpl.
        destruct (to_scan3 n0 p0) eqn:Hscan3; simpl; auto.
        -- destruct (Hdisj n0 p0) as [H | H]; [congruence|rewrite H; auto using orb_false_r].
        -- destruct (is_eq p p0 && (n =? n0)%nat) eqn:Hd; simpl; auto using andb_true_r.
           reflect. destruct Hd as [Heqp Hn]. rewrite Heqp, Hn in Hscanp. congruence.
Qed.

(** * The semantics of polyhedral programs with lexicographical ordering *)

Inductive poly_lex_semantics : (nat -> list Z -> bool) -> Poly_Program -> mem -> mem -> Prop :=
| PolyLexDone : forall to_scan prog mem, (forall n p, to_scan n p = false) -> poly_lex_semantics to_scan prog mem mem
| PolyLexProgress : forall to_scan prog mem1 mem2 mem3 poly_instr n p,
    to_scan n p = true -> nth_error prog n = Some poly_instr ->
    (forall n2 p2, lex_compare p2 p = Lt -> to_scan n2 p2 = false) ->
    instr_semantics poly_instr.(pi_instr) (affine_product poly_instr.(pi_transformation) p) mem1 mem2 ->
    poly_lex_semantics (scanned to_scan n p) prog mem2 mem3 ->
    poly_lex_semantics to_scan prog mem1 mem3.

Theorem poly_lex_semantics_extensionality :
  forall to_scan1 prog mem1 mem2,
    poly_lex_semantics to_scan1 prog mem1 mem2 -> forall to_scan2, (forall n p, to_scan1 n p = to_scan2 n p) -> poly_lex_semantics to_scan2 prog mem1 mem2.
Proof.
  intros to_scan1 prog mem1 mem2 Hsem.
  induction Hsem as [to_scan3 prog1 mem4 Hdone|to_scan3 prog1 mem3 mem4 mem5 pi n p Hscanp Heqpi Hts Hsem1 Hsem2 IH].
  - intros. constructor. intros. eauto.
  - intros to_scan2 Heq. econstructor; eauto. apply IH. intros. autounfold. rewrite Heq. auto.
Qed.

Lemma poly_lex_semantics_pis_ext_single :
  forall pis1 pis2 to_scan mem1 mem2,
    Forall2 (fun pi1 pi2 => pi1.(pi_instr) = pi2.(pi_instr) /\ pi1.(pi_transformation) = pi2.(pi_transformation)) pis1 pis2 ->
    poly_lex_semantics to_scan pis1 mem1 mem2 -> poly_lex_semantics to_scan pis2 mem1 mem2.
Proof.
  intros pis1 pis2 to_scan mem1 mem2 Hsame Hsem.
  induction Hsem as [to_scan1 prog mem Hdone|to_scan1 prog mem1 mem2 mem3 pi n p Hscanp Heqpi Hts Hsem1 Hsem2 IH].
  - apply PolyLexDone; auto.
  - destruct (Forall2_nth_error _ _ _ _ _ _ _ Hsame Heqpi) as [pi2 [Hpi2 [H1 H2]]].
    eapply PolyLexProgress; [exact Hscanp|exact Hpi2|exact Hts| |apply IH; auto].
    rewrite H1, H2 in *; auto.
Qed.

Lemma poly_lex_semantics_pis_ext_iff :
  forall pis1 pis2 to_scan mem1 mem2,
    Forall2 (fun pi1 pi2 => pi1.(pi_instr) = pi2.(pi_instr) /\ pi1.(pi_transformation) = pi2.(pi_transformation)) pis1 pis2 ->
    poly_lex_semantics to_scan pis1 mem1 mem2 <-> poly_lex_semantics to_scan pis2 mem1 mem2.
Proof.
  intros pis1 pis2 to_scan mem1 mem2 Hsame.
  split.
  - apply poly_lex_semantics_pis_ext_single; auto.
  - apply poly_lex_semantics_pis_ext_single.
    eapply Forall2_imp; [|apply Forall2_sym; exact Hsame].
    intros x y H; simpl in *; destruct H; auto.
Qed.

Lemma poly_lex_semantics_ext_iff :
  forall pis to_scan1 to_scan2 mem1 mem2,
    (forall n p, to_scan1 n p = to_scan2 n p) ->
    poly_lex_semantics to_scan1 pis mem1 mem2 <-> poly_lex_semantics to_scan2 pis mem1 mem2.
Proof.
  intros pis to_scan1 to_scan2 mem1 mem2 Hsame.
  split; intros H.
  - eapply poly_lex_semantics_extensionality; [exact H|]. auto.
  - eapply poly_lex_semantics_extensionality; [exact H|]. auto.
Qed.

Theorem poly_lex_concat :
  forall to_scan1 prog mem1 mem2,
    poly_lex_semantics to_scan1 prog mem1 mem2 ->
    forall to_scan2 mem3,
    wf_scan to_scan1 ->
    (forall n p, to_scan1 n p = false \/ to_scan2 n p = false) ->
    (forall n1 p1 n2 p2, lex_compare p2 p1 = Lt -> to_scan1 n1 p1 = false \/ to_scan2 n2 p2 = false) ->
    poly_lex_semantics to_scan2 prog mem2 mem3 ->
    poly_lex_semantics (fun n p => to_scan1 n p || to_scan2 n p) prog mem1 mem3.
Proof.
  intros to_scan1 prog mem1 mem2 Hsem.
  induction Hsem as [to_scan3 prog1 mem4 Hdone|to_scan3 prog1 mem4 mem5 mem6 pi n p Hscanp Heqpi Hts Hsem1 Hsem2 IH].
  - intros to_scan2 mem3 Hwf1 Hdisj Hcmp Hsem1. eapply poly_lex_semantics_extensionality; eauto. intros. rewrite Hdone. auto.
  - intros to_scan2 mem3 Hwf1 Hdisj Hcmp Hsem3. eapply PolyLexProgress with (n := n) (p := p); eauto.
    + rewrite Hscanp. auto.
    + intros n2 p2 Hts2.
      reflect. split.
      * apply (Hts n2 p2); auto.
      * destruct (Hcmp n p n2 p2) as [H | H]; auto; congruence.
    + eapply poly_lex_semantics_extensionality; [apply IH|]; eauto.
      * apply scanned_wf_compat; auto.
      * intros n2 p2. autounfold. destruct (Hdisj n2 p2) as [H | H]; rewrite H; auto.
      * intros n1 p1 n2 p2 Hcmp1.
        destruct (Hcmp n1 p1 n2 p2) as [H | H]; autounfold; auto. rewrite H. simpl.
        destruct (is_eq p p1 && (n =? n1)%nat) eqn:Hd; simpl; auto.
      * intros n0 p0. autounfold. simpl.
        destruct (to_scan3 n0 p0) eqn:Hscan3; simpl; auto.
        -- destruct (Hdisj n0 p0) as [H | H]; [congruence|rewrite H; auto using orb_false_r].
        -- destruct (is_eq p p0 && (n =? n0)%nat) eqn:Hd; simpl; auto using andb_true_r.
           reflect. destruct Hd as [Heqp Hn]. rewrite Heqp, Hn in Hscanp. congruence.
Qed.

Theorem poly_lex_concat_seq :
  forall A to_scans (l : list A) prog mem1 mem2,
    iter_semantics (fun x => poly_lex_semantics (to_scans x) prog) l mem1 mem2 ->
    (forall x, wf_scan (to_scans x)) ->
    (forall x1 k1 x2 k2 n p, to_scans x1 n p = true -> to_scans x2 n p = true -> nth_error l k1 = Some x1 -> nth_error l k2 = Some x2 -> k1 = k2) ->
    (forall x1 n1 p1 k1 x2 n2 p2 k2, lex_compare p2 p1 = Lt -> to_scans x1 n1 p1 = true -> to_scans x2 n2 p2 = true -> nth_error l k1 = Some x1 -> nth_error l k2 = Some x2 -> (k2 <= k1)%nat) ->
    poly_lex_semantics (fun n p => existsb (fun x => to_scans x n p) l) prog mem1 mem2.
Proof.
  intros A to_scans l1 prog mem1 mem3 Hsem.
  induction Hsem as [mem|x l mem1 mem2 mem3 Hsem1 Hsem2 IH].
  - intros Hwf Hscans Hcmp.
    simpl.
    apply PolyLexDone; auto.
  - intros Hwf Hscans Hcmp.
    eapply poly_lex_semantics_extensionality.
    + eapply poly_lex_concat; [exact Hsem1| | | |apply IH; auto].
      * apply Hwf.
      * intros n p. simpl.
        destruct (to_scans x n p) eqn:Hscanl; [|auto]. right.
        apply not_true_is_false; rewrite existsb_exists; intros [x1 [Hin Hscanx1]].
        apply In_nth_error in Hin; destruct Hin as [u Hu].
        specialize (Hscans x O x1 (S u) n p Hscanl Hscanx1).
        simpl in Hscans. intuition congruence.
      * intros n1 p1 n2 p2 H.
        destruct (to_scans x n1 p1) eqn:Hscanl; [|auto]. right.
        apply not_true_is_false; rewrite existsb_exists; intros [x1 [Hin Hscanx1]].
        apply In_nth_error in Hin; destruct Hin as [u Hu].
        specialize (Hcmp x n1 p1 O x1 n2 p2 (S u) H Hscanl Hscanx1).
        intuition lia.
      * intros x1 k1 x2 k2 n p H1 H2 H3 H4; specialize (Hscans x1 (S k1) x2 (S k2) n p).
        intuition congruence.
      * intros x1 n1 p1 k1 x2 n2 p2 k2 H1 H2 H3 H4 H5; specialize (Hcmp x1 n1 p1 (S k1) x2 n2 p2 (S k2)).
        intuition lia.
    + intros n p. simpl. reflexivity.
Qed.

(** * Translating a program from explicit scheduling to lexicographical scanning *)

Definition insert_zeros (d : nat) (i : nat) (l : list Z) := resize i l ++ repeat 0 d ++ skipn i l.
Definition insert_zeros_constraint (d : nat) (i : nat) (c : list Z * Z) := (insert_zeros d i (fst c), snd c).

(** [make_null_poly d n] creates a polyhedron with the constraints that the variables from [d] to [d+n-1] are null *)
Fixpoint make_null_poly (d : nat) (n : nat) :=
  match n with
  | O => nil
  | S n => (repeat 0 d ++ (-1 :: nil), 0) :: (repeat 0 d ++ (1 :: nil), 0) :: make_null_poly (S d) n
  end.

(** [make_sched_poly d i env_size l] adds the lexicographical constraints in [l] as equalities, preserving the [env_size] first variables,
    and inserting [d] variables after that. *)
Fixpoint make_sched_poly (d : nat) (i : nat) (env_size : nat) (l : list (list Z * Z)) :=
  (* add scheduling constraints in polyhedron after env, so that with fixed env, lexicographical ordering preserves semantics *)
  match l with
  | nil => make_null_poly (i + env_size)%nat (d - i)%nat
  | (v, c) :: l =>
    let vpref := resize env_size v in
    let vsuf := skipn env_size v in
    (vpref ++ repeat 0 i ++ (-1 :: repeat 0 (d - i - 1)%nat) ++ vsuf, -c)
      :: (mult_vector (-1) vpref ++ repeat 0 i ++ (1 :: repeat 0 (d - i - 1)%nat) ++ (mult_vector (-1) vsuf), c)
      :: make_sched_poly d (S i) env_size l
  end.

Theorem make_null_poly_correct :
  forall n d p q r, length p = d -> length q = n -> in_poly (p ++ q ++ r) (make_null_poly d n) = is_null q.
Proof.
  induction n.
  - intros; destruct q; simpl in *; auto; lia.
  - intros d p q r Hlp Hlq.
    destruct q as [|x q]; simpl in *; [lia|].
    unfold satisfies_constraint; simpl.
    repeat (rewrite dot_product_app; [|rewrite repeat_length; lia]; simpl).
    autorewrite with vector.
    assert (He : p ++ x :: q ++ r = (p ++ (x :: nil)) ++ q ++ r).
    { rewrite <- app_assoc; auto. }
    rewrite He. rewrite IHn; [|rewrite app_length; simpl; lia|lia].
    rewrite andb_assoc. f_equal.
    destruct (x =? 0) eqn:Hx; reflect; lia.
Qed.

Theorem make_sched_poly_correct_aux :
  forall l i d es, (length l <= d - i)%nat ->
           forall p q r s, length p = es -> length q = i -> length r = (d - i)%nat ->
                    in_poly (p ++ q ++ r ++ s) (make_sched_poly d i es l) = is_eq r (affine_product l (p ++ s)).
Proof.
  induction l.
  - intros. simpl in *. rewrite is_eq_nil_right. rewrite app_assoc. apply make_null_poly_correct; auto. rewrite app_length; lia.
  - intros i d es Hlength p q r s Hlp Hlq Hlr.
    simpl in *. destruct a as [v c]. simpl in *.
    destruct r as [|x r]; simpl in *; [lia|].
    unfold satisfies_constraint; simpl.
    repeat (rewrite dot_product_app; [|rewrite ?repeat_length, ?mult_vector_length, ?resize_length; lia]; simpl).
    autorewrite with vector.
    assert (He : p ++ q ++ x :: r ++ s = p ++ (q ++ (x :: nil)) ++ r ++ s).
    { rewrite <- app_assoc. auto. }
    rewrite He. rewrite IHl; [|lia|auto|rewrite app_length;simpl;lia|lia].
    rewrite andb_assoc. f_equal.
    assert (Hde : dot_product v (p ++ s) = dot_product p (resize es v) + dot_product s (skipn es v)).
    { rewrite <- dot_product_app by (rewrite resize_length; lia).
      rewrite dot_product_commutative. rewrite resize_skipn_eq. reflexivity.
    }
    destruct (x =? dot_product v (p ++ s) + c) eqn:Hx; reflect; lia.
Qed.

Theorem make_sched_poly_correct :
  forall l d es, (length l <= d)%nat ->
            forall p q r, length p = es -> length q = d ->
                    in_poly (p ++ q ++ r) (make_sched_poly d 0%nat es l) = is_eq q (affine_product l (p ++ r)).
Proof.
  intros. apply make_sched_poly_correct_aux with (q := nil); auto; lia.
Qed.

Theorem make_null_poly_nrl :
  forall n d, (poly_nrl (make_null_poly d n) <= d + n)%nat.
Proof.
  induction n.
  - intros; unfold poly_nrl; simpl; lia.
  - intros d. simpl. unfold poly_nrl; simpl.
    rewrite !Nat.max_lub_iff.
    split; [|split; [|specialize (IHn (S d)); unfold poly_nrl in *; lia]];
      rewrite <- nrlength_def, resize_app_le, repeat_length by (rewrite repeat_length; lia);
      replace (d + S n - d)%nat with (S n) by lia; simpl;
        f_equiv; f_equiv; rewrite resize_eq; simpl; (reflexivity || lia).
Qed.

Theorem make_sched_poly_nrl_aux :
  forall l i d es, (length l + i <= d)%nat -> (poly_nrl (make_sched_poly d i es l) <= d + (Nat.max es (poly_nrl l)))%nat.
Proof.
  induction l.
  - simpl; intros i d es H.
    generalize (make_null_poly_nrl (d - i)%nat (i + es)%nat). lia.
  - intros i d es H; simpl in *. destruct a as [a c]. unfold poly_nrl in *; simpl in *.
    rewrite !Nat.max_lub_iff. split; [|split; [|rewrite IHl; lia]].
    all: rewrite nrlength_app; transitivity (es + (i + S ((d - i - 1) + (nrlength a - es))))%nat; [|lia].
    all: rewrite ?mult_vector_length, resize_length; apply Nat.add_le_mono_l.
    all: rewrite nrlength_app, repeat_length; apply Nat.add_le_mono_l.
    all: rewrite nrlength_cons; apply -> Nat.succ_le_mono.
    all: rewrite nrlength_app, repeat_length; apply Nat.add_le_mono_l.
    all: rewrite ?nrlength_mult, nrlength_skipn; lia.
Qed.

Theorem make_sched_poly_nrl :
  forall l d es, (length l <= d)%nat -> (poly_nrl (make_sched_poly d 0%nat es l) <= d + (Nat.max es (poly_nrl l)))%nat.
Proof.
  intros; apply make_sched_poly_nrl_aux; lia.
Qed.

Lemma insert_zeros_nrl :
  forall d es v, (nrlength (insert_zeros d es v) <= d + nrlength v)%nat.
Proof.
  induction es.
  - intros v; unfold insert_zeros; simpl. rewrite nrlength_app, repeat_length; lia.
  - intros [|x v]; unfold insert_zeros in *; simpl.
    + case_if eq H; reflect; [lia|].
      exfalso; apply H. apply nrlength_null_zero.
      unfold is_null. rewrite !forallb_app; reflect.
      split; [apply resize_nil_null|]. split; [apply repeat_zero_is_null|auto].
    + case_if eq H1; reflect; [lia|].
      case_if eq H2; reflect.
      * destruct H2 as [-> H2]; apply nrlength_zero_null in H2. destruct H1 as [H1 | H1]; [lia|].
        exfalso; apply H1. apply nrlength_null_zero.
        rewrite resize_null_repeat by auto.
        unfold is_null; rewrite !forallb_app; reflect.
        split; [apply repeat_zero_is_null|]. split; [apply repeat_zero_is_null|].
        apply nrlength_zero_null; apply nrlength_null_zero in H2.
        rewrite nrlength_skipn; lia.
      * specialize (IHes v). lia.
Qed.

Definition pi_elim_schedule (d : nat) (env_size : nat) (pi : Polyhedral_Instruction) :=
  {|
    pi_instr := pi.(pi_instr) ;
    pi_schedule := nil ;
    pi_transformation := map (insert_zeros_constraint d env_size) pi.(pi_transformation) ;
    pi_poly := make_sched_poly d 0%nat env_size pi.(pi_schedule) ++
               map (insert_zeros_constraint d env_size) pi.(pi_poly) ;
  |}.

Lemma pi_elim_schedule_nrl :
  forall d es pi,
    (length pi.(pi_schedule) <= d)%nat ->
    (poly_nrl (pi_elim_schedule d es pi).(pi_poly) <= d + (Nat.max es (Nat.max (poly_nrl pi.(pi_poly)) (poly_nrl pi.(pi_schedule)))))%nat.
Proof.
  intros d es pi H. simpl.
  rewrite poly_nrl_app. rewrite Nat.max_lub_iff; split.
  - rewrite make_sched_poly_nrl; lia.
  - unfold poly_nrl, insert_zeros_constraint in *. rewrite map_map. apply list_le_max; intros u Hu.
    rewrite in_map_iff in Hu. destruct Hu as [c [Hu Hc]]; simpl in *.
    transitivity (d + nrlength (fst c))%nat;
      [|apply Nat.add_le_mono_l; rewrite !Nat.max_le_iff; right; left; apply list_max_ge; rewrite in_map_iff; exists c; auto].
    rewrite <- Hu; apply insert_zeros_nrl.
Qed.

Definition elim_schedule (d : nat) (env_size : nat) (p : Poly_Program) := map (pi_elim_schedule d env_size) p.

Lemma split3_eq :
  forall i d l, resize i l ++ resize d (skipn i l) ++ skipn (d + i)%nat l =v= l.
Proof.
  intros.
  rewrite <- is_eq_veq.
  rewrite is_eq_app_left. autorewrite with vector. rewrite is_eq_reflexive. simpl.
  rewrite is_eq_app_left. autorewrite with vector. rewrite is_eq_reflexive. simpl.
  rewrite skipn_skipn. apply is_eq_reflexive.
Qed.

Lemma insert_zeros_product_skipn :
  forall d i l1 l2, dot_product (insert_zeros d i l1) l2 = dot_product l1 (resize i l2 ++ skipn (d + i)%nat l2).
Proof.
  intros.
  unfold insert_zeros.
  rewrite !dot_product_app_left, dot_product_app_right.
  autorewrite with vector. rewrite repeat_length.
  rewrite skipn_skipn. lia.
Qed.

Lemma affine_product_skipn :
  forall d i m l, affine_product (map (insert_zeros_constraint d i) m) l = affine_product m (resize i l ++ skipn (d + i)%nat l).
Proof.
  intros. unfold affine_product. rewrite map_map.
  apply map_ext. intros.
  unfold insert_zeros_constraint; simpl.
  rewrite insert_zeros_product_skipn. auto.
Qed.

(** * Schedule elimination is correct *)

Theorem poly_elim_schedule_semantics_preserve :
  forall d es env to_scan_lex prog_lex mem1 mem2,
    poly_lex_semantics to_scan_lex prog_lex mem1 mem2 ->
    forall to_scan prog,
      prog_lex = elim_schedule d es prog ->
      wf_scan to_scan -> wf_scan to_scan_lex ->
      (forall n pi, nth_error prog n = Some pi -> (length pi.(pi_schedule) <= d)%nat) ->
      (forall n p q ts pi, nth_error prog n = Some pi -> length p = es -> length ts = d ->
                      to_scan_lex n (p ++ ts ++ q) = is_eq ts (affine_product pi.(pi_schedule) (p ++ q)) && to_scan n (p ++ q)) ->
      (forall n p q, length p = es -> to_scan n (p ++ q) = true -> p =v= env) ->
      (forall n p, nth_error prog n = None -> to_scan n p = false) ->
      poly_semantics to_scan prog mem1 mem2.
Proof.
  intros d es env to_scan_lex prog mem1 mem2 Hsem.
  induction Hsem as [to_scan_l1 prog_l1 mem3 Hdone|to_scan_l1 prog_l1 mem3 mem4 mem5 pi n p Hscanp Heqpi Hts Hsem1 Hsem2 IH].
  - intros to_scan prog Hprogeq Hwf Hwflex Hsched_length Hcompat Hscanenv Hout.
    apply PolyDone. intros n p.
    destruct (nth_error prog n) as [pi|] eqn:Heq.
    + specialize (Hcompat n (resize es p) (skipn es p) (resize d (affine_product pi.(pi_schedule) p)) pi).
      rewrite Hdone in Hcompat.
      rewrite resize_skipn_eq in Hcompat. rewrite resize_eq in Hcompat.
      * simpl in Hcompat. symmetry; apply Hcompat; auto.
      * unfold affine_product. rewrite map_length. eauto.
    + auto.
  - intros to_scan prog Hprogeq Hwf Hwflex Hsched_length Hcompat Hscanenv Hout.
    rewrite <- split3_eq with (d := d) (i := es) in Hscanp.
    rewrite Hprogeq in *; unfold elim_schedule in Heqpi.
    destruct (nth_error prog n) as [pi1|] eqn:Hpi1; [| rewrite map_nth_error_none in Heqpi; congruence ].
    erewrite map_nth_error in Heqpi; eauto; inversion Heqpi as [Heqpi1].
    rewrite Hcompat with (pi := pi1) in Hscanp; auto.
    reflect; destruct Hscanp as [Heqp Hscan].
    eapply PolyProgress with (n := n) (p := resize es p ++ skipn (d + es)%nat p); eauto.
    + intros n2 p2 pi2 Heqpi2 Hcmp.
      specialize (Hts n2 (resize es p2 ++ (resize d (affine_product pi2.(pi_schedule) p2)) ++ skipn es p2)).
      rewrite Hcompat with (pi := pi2) in Hts; auto.
      rewrite resize_skipn_eq in Hts.
      rewrite resize_eq in Hts by (unfold affine_product; rewrite map_length; eauto). simpl in Hts.
      destruct (to_scan n2 p2) eqn:Hscan2; auto. apply Hts.
      rewrite <- split3_eq with (l := p) (d := d) (i := es).
      rewrite !lex_compare_app by (rewrite !resize_length; reflexivity).
      rewrite Hscanenv with (p := resize es p2) by (apply resize_length || rewrite resize_skipn_eq; apply Hscan2).
      rewrite Hscanenv with (p := resize es p) by (apply resize_length || apply Hscan).
      rewrite lex_compare_reflexive. simpl.
      rewrite Heqp. rewrite resize_eq by (unfold affine_product; rewrite map_length; eauto).
      rewrite Hcmp. reflexivity.
    + rewrite <- Heqpi1 in Hsem1; unfold pi_elim_schedule in Hsem1; simpl in *.
      rewrite affine_product_skipn in Hsem1. apply Hsem1.
    + apply IH; auto.
      * apply scanned_wf_compat; auto.
      * apply scanned_wf_compat; auto.
      * intros n0 p0 q0 ts pi0 Hpi0 Hlp0 Hlts.
        unfold scanned. rewrite Hcompat with (pi := pi0); auto.
        destruct (is_eq ts (affine_product (pi_schedule pi0) (p0 ++ q0))) eqn:Htseq; auto.
        simpl.
        f_equal; f_equal.
        destruct (n =? n0)%nat eqn:Heqn; [|rewrite !andb_false_r; auto]. rewrite !andb_true_r.
        rewrite <- split3_eq with (l := p) (d := d) (i := es) at 1.
        rewrite !is_eq_app by (rewrite resize_length; auto).
        destruct (is_eq (resize es p) p0) eqn:Heqp0; simpl; auto.
        destruct (is_eq (skipn (d + es)%nat p) q0) eqn:Heqq0; simpl; auto using andb_false_r.
        rewrite andb_true_r.
        reflect. rewrite Heqn in *.
        assert (Heqpi0 : pi0 = pi1) by congruence. rewrite Heqpi0 in *.
        rewrite Heqp. rewrite Htseq. f_equal.
        assert (H : p0 ++ q0 =v= resize es p ++ skipn (d + es) p); [|rewrite H; reflexivity].
        rewrite <- is_eq_veq. rewrite is_eq_app by (rewrite resize_length; auto).
        reflect; split; symmetry; assumption.
      * intros n0 p0 q0 H. unfold scanned. reflect. intros [H1 H2]. eapply Hscanenv; eauto.
      * intros n0 p0 H. unfold scanned. rewrite Hout; auto.
Qed.

(** * Semantics in a fixed environment *)

Definition env_scan (prog : Poly_Program) (env : list Z) (dim : nat) (n : nat) (p : list Z) :=
  match nth_error prog n with
  | Some pi => is_eq env (resize (length env) p) && is_eq p (resize dim p) && in_poly p pi.(pi_poly)
  | None => false
  end.

Definition env_poly_semantics (env : list Z) (dim : nat) (prog : Poly_Program) (mem1 mem2 : mem) :=
  poly_semantics (env_scan prog env dim) prog mem1 mem2.

Definition env_poly_lex_semantics (env : list Z) (dim : nat) (prog : Poly_Program) (mem1 mem2 : mem) :=
  poly_lex_semantics (env_scan prog env dim) prog mem1 mem2.

Instance env_scan_proper : forall prog env dim, Proper (eq ==> veq ==> eq) (env_scan prog env dim).
Proof.
  intros prog env dim n1 n2 Hn p1 p2 Hp. rewrite Hn. unfold env_scan.
  destruct (nth_error prog n2) as [pi|]; simpl; auto.
  rewrite Hp at 1 2 4; rewrite Hp at 1. reflexivity.
Qed.

(** * Schedule elimination in a fixed environment is correct as well *)

Theorem poly_elim_schedule_semantics_env_preserve :
  forall d es env dim prog mem1 mem2,
    es = length env ->
    (es <= dim)%nat ->
    env_poly_lex_semantics env (dim + d) (elim_schedule d es prog) mem1 mem2 ->
    (forall n pi, nth_error prog n = Some pi -> (length pi.(pi_schedule) <= d)%nat) ->
    env_poly_semantics env dim prog mem1 mem2.
Proof.
  intros d es env dim prog mem1 mem2 Hlength Hdim Hsem Hsched_length.
  unfold env_poly_semantics. unfold env_poly_lex_semantics in Hsem.
  eapply poly_elim_schedule_semantics_preserve.
  - exact Hsem.
  - reflexivity.
  - apply env_scan_proper.
  - apply env_scan_proper.
  - exact Hsched_length.
  - intros n p q ts pi Heqpi Hlp Hlts.
    unfold env_scan. unfold elim_schedule. rewrite map_nth_error with (d := pi); auto. rewrite Heqpi.
    rewrite <- Hlength. unfold pi_elim_schedule; simpl.
    rewrite !resize_app with (n := es) by apply Hlp.
    destruct (is_eq env p); simpl; auto using andb_false_r.
    rewrite in_poly_app. rewrite andb_comm. rewrite <- andb_assoc. f_equal.
    + apply make_sched_poly_correct; eauto.
    + rewrite andb_comm. f_equal.
      * rewrite !resize_app_le by lia.
        rewrite !is_eq_app by lia. rewrite !is_eq_reflexive. simpl.
        f_equal. f_equal. lia.
      * unfold in_poly. rewrite forallb_map. apply forallb_ext.
        intros c. unfold satisfies_constraint. unfold insert_zeros_constraint. simpl.
        f_equal. rewrite dot_product_commutative. rewrite insert_zeros_product_skipn.
        rewrite resize_app by apply Hlp.
        rewrite app_assoc. rewrite skipn_app; [|rewrite app_length; lia].
        apply dot_product_commutative.
  - intros n p q Hlp Hscan. unfold env_scan in Hscan.
    destruct (nth_error prog n) as [pi|]; [|congruence].
    reflect. destruct Hscan as [[He Hr] Hp].
    rewrite resize_app in He by congruence. symmetry. exact He.
  - intros n p Hout. unfold env_scan. rewrite Hout. auto.
Qed.


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

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

Print Assumptions mul.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section VotesWithLogTermSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition votesWithLog_term_sanity net :=
    forall t l hs h,
      In (t, l, hs) (votesWithLog (fst (nwState net h))) ->
      t <= currentTerm (snd (nwState net h)).

  Class votesWithLog_term_sanity_interface : Prop :=
    {
      votesWithLog_term_sanity_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          votesWithLog_term_sanity net
    }.
End VotesWithLogTermSanity.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


(* This file is generated by Why3's Coq 8.4 driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require list.List.
Require list.Length.
Require int.Int.
Require list.Mem.
Require list.Append.

(* Why3 assumption *)
Definition unit := unit.

Axiom char : Type.
Parameter char_WhyType : WhyType char.
Existing Instance char_WhyType.

(* Why3 assumption *)
Inductive regexp :=
  | Empty : regexp
  | Epsilon : regexp
  | Char : char -> regexp
  | Alt : regexp -> regexp -> regexp
  | Concat : regexp -> regexp -> regexp
  | Star : regexp -> regexp.
Axiom regexp_WhyType : WhyType regexp.
Existing Instance regexp_WhyType.

(* Why3 assumption *)
Definition word := (list char).

(* Why3 assumption *)
Inductive mem : (list char) -> regexp -> Prop :=
  | mem_eps : (mem nil Epsilon)
  | mem_char : forall (c:char), (mem (cons c nil) (Char c))
  | mem_altl : forall (w:(list char)) (r1:regexp) (r2:regexp), (mem w r1) ->
      (mem w (Alt r1 r2))
  | mem_altr : forall (w:(list char)) (r1:regexp) (r2:regexp), (mem w r2) ->
      (mem w (Alt r1 r2))
  | mem_concat : forall (w1:(list char)) (w2:(list char)) (r1:regexp)
      (r2:regexp), (mem w1 r1) -> ((mem w2 r2) -> (mem (List.app w1 w2)
      (Concat r1 r2)))
  | mems1 : forall (r:regexp), (mem nil (Star r))
  | mems2 : forall (w1:(list char)) (w2:(list char)) (r:regexp), (mem w1
      r) -> ((mem w2 (Star r)) -> (mem (List.app w1 w2) (Star r))).

(* Why3 goal *)
Theorem inversion_mem_star_gen : forall (c:char) (w:(list char)) (r:regexp)
  (w':(list char)) (r':regexp), ((w' = (cons c w)) /\ (r' = (Star r))) ->
  ((mem w' r') -> exists w1:(list char), exists w2:(list char),
  (w = (List.app w1 w2)) /\ ((mem (cons c w1) r) /\ (mem w2 r'))).
(* Why3 intros c w r w' r' (h1,h2) h3. *)
intros c w r w' r' (h1,h2) h3.
induction h3; try (discriminate h2).
discriminate h1.
injection h2; clear h2; intros; subst.

destruct w1.

now apply IHh3_2.

simpl in h1.
injection h1; clear h1; intros; subst.
exists w1.
exists w2.
split; auto.

Qed.


Require Import Problem List.

Theorem solution: task.
Proof.
  unfold task.
  destruct l; [discriminate|].
  rewrite <- app_comm_cons.
  discriminate.
Qed.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics.
Require Import HoTT.Spaces.No.Core.

Local Open Scope path_scope.
Local Open Scope surreal_scope.

(** * Negation of surreal numbers *)

(** Negation requires the option sorts to be symmetric. *)
Class HasNegation (S : OptionSort)
  := symmetric_options : forall L R, InSort S L R -> InSort S R L.
Global Existing Instance symmetric_options.

Global Instance hasnegation_maxsort : HasNegation MaxSort
  := fun _ _ _ => tt.

Global Instance hasnegation_decsort : HasNegation DecSort.
Proof.
  intros L R [? ?]; split; assumption.
Qed.

Section HasNegation.
  Context {S : OptionSort} `{HasNegation S}.
  Let No := GenNo S.

  Definition negate : No -> No.
  Proof.
    simple refine (No_rec No (fun x y => y <= x) (fun x y => y < x)
                          _ _ _ _ _); intros.
    - exact {{ fxR | fxL // fun r l => fxcut l r }}.
    - apply path_No; assumption.
    - cbn in *. apply le_lr; intros; [ apply dq | apply dp ].
    - cbn in *. apply lt_r with l; intros; assumption.
    - cbn in *. apply lt_l with r; intros; assumption.
  Defined.

  (** More useful is the following rewriting lemma. *)
  Definition negate_cut
             {L R : Type@{i} } {Sx : InSort@{i} S L R}
             (xL : L -> No) (xR : R -> No)
             (xcut : forall (l : L) (r : R), xL l < xR r)
    : { nxcut : forall r l, negate (xR r) < negate (xL l) &
        negate {{ xL | xR // xcut }} =
        {{ (fun r => negate (xR r)) | (fun l => negate (xL l)) // nxcut }} }.
  Proof.
    eexists.
    unfold negate at 1;rewrite No_rec_cut.
    reflexivity.
  Defined.

  (** The following proof verifies that [No_rec] applied to a cut reduces definitionally to a cut with the expected options (although it does produce quite a large term). *)
  Context `{InSort S Empty Empty} `{InSort S Unit Empty}.
  Goal negate one = minusone.
  Proof.
    unfold one;rewrite (negate_cut _ _ _).2.
    apply path_No; apply le_lr; intros.
    (** Since [le_lr] only proves inequality of cuts, this would not work if [negate] didn't compute to a cut when applied to a cut. *)
    - elim l.
    - apply lt_r with r.
      unfold zero; rewrite (negate_cut _ _ _).2.
      apply le_lr; apply Empty_ind.
    - elim l.
    - unfold zero; rewrite (negate_cut _ _ _).2.
      apply lt_r with r.
      apply le_lr; apply Empty_ind.
  Qed.

End HasNegation.


From ZornsLemma Require Export FunctionProperties.
From ZornsLemma Require Import DecidableDec.
From Coq Require Import Description.
From Coq Require Import Classical.

(* CSB = Cantor-Schroeder-Bernstein theorem *)

Section CSB.
Variable X Y:Type.
Variable f:X->Y.
Variable g:Y->X.
Hypothesis f_inj: injective f.
Hypothesis g_inj: injective g.

Inductive X_even: X->Prop :=
  | not_g_img: forall x:X, (forall y:Y, g y <> x) -> X_even x
  | g_Y_odd: forall y:Y, Y_odd y -> X_even (g y)
with Y_odd: Y->Prop :=
  | f_X_even: forall x:X, X_even x -> Y_odd (f x).
Inductive X_odd: X->Prop :=
  | g_Y_even: forall y:Y, Y_even y -> X_odd (g y)
with Y_even: Y->Prop :=
  | not_f_img: forall y:Y, (forall x:X, f x <> y) -> Y_even y
  | f_X_odd: forall x:X, X_odd x -> Y_even (f x).

Scheme X_even_coind := Minimality for X_even Sort Prop
  with Y_odd_coind := Minimality for Y_odd Sort Prop.
Scheme X_odd_coind := Minimality for X_odd Sort Prop
  with Y_even_coind := Minimality for Y_even Sort Prop.

Lemma even_odd_excl: forall x:X, ~(X_even x /\ X_odd x).
Proof.
intro.
assert (X_even x -> ~ X_odd x).
2:tauto.
pose proof (X_even_coind (fun x:X => ~ X_odd x) (fun y:Y => ~ Y_even y)).
apply H.
- intuition.
  destruct H1.
  apply H0 with y.
  reflexivity.
- intuition.
  inversion H2.
  apply g_inj in H3.
  apply H1.
  rewrite <- H3.
  assumption.
- intuition.
  inversion H2.
  + apply H3 with x0.
    reflexivity.
  + apply f_inj in H3.
    apply H1.
    rewrite <- H3.
    assumption.
Qed.

Lemma even_odd_excl2: forall y:Y, ~(Y_even y /\ Y_odd y).
Proof.
intro.
assert (Y_odd y -> ~ Y_even y).
2:tauto.
pose proof (Y_odd_coind (fun x:X => ~ X_odd x) (fun y:Y => ~ Y_even y)).
apply H; intuition.
- destruct H1.
  apply H0 with y0.
  reflexivity.
- inversion H2.
  apply g_inj in H3.
  apply H1.
  rewrite <- H3.
  assumption.
- inversion H2.
  + apply H3 with x.
    reflexivity.
  + apply f_inj in H3.
    apply H1.
    rewrite <- H3.
    assumption.
Qed.

Definition finv: forall y:Y, (exists x:X, f x = y) ->
  { x:X | f x = y }.
intros.
apply constructive_definite_description.
destruct H.
exists x.
red; split.
{ assumption. }
intros.
apply f_inj.
transitivity y; trivial.
symmetry; trivial.
Defined.

Definition ginv: forall x:X, (exists y:Y, g y = x) ->
  { y:Y | g y = x }.
intros.
apply constructive_definite_description.
destruct H.
exists x0.
red; split.
{ assumption. }
intros.
apply g_inj.
transitivity x; trivial; symmetry; trivial.
Defined.

Definition ginv_odd: forall x:X, X_odd x ->
  { y:Y | g y = x }.
intros.
apply ginv.
destruct H.
exists y.
reflexivity.
Defined.

Definition finv_noteven: forall y:Y, ~ Y_even y ->
  { x:X | f x = y }.
intros.
apply finv.
apply NNPP.
red; intro.
contradict H.
constructor 1.
intro; red; intro.
apply H0.
exists x.
assumption.
Defined.

Definition CSB_bijection (x:X) : Y :=
  match (classic_dec (X_odd x)) with
  | left o => proj1_sig (ginv_odd x o)
  | right _ => f x
  end.
Definition CSB_bijection2 (y:Y) : X :=
  match (classic_dec (Y_even y)) with
  | left _ => g y
  | right ne => proj1_sig (finv_noteven y ne)
  end.

Lemma CSB_comp1: forall x:X, CSB_bijection2 (CSB_bijection x) = x.
Proof.
intro.
unfold CSB_bijection; case (classic_dec (X_odd x)).
- intro.
  destruct ginv_odd.
  simpl.
  unfold CSB_bijection2;
    case (classic_dec (Y_even x1));
    auto.
  intro.
  destruct x0.
  contradict n.
  apply g_inj in e.
  rewrite e.
  assumption.
- intro.
  unfold CSB_bijection2; case (classic_dec (Y_even (f x))).
  + intro.
    contradict n.
    inversion y.
    * pose proof (H x).
      contradict H1; reflexivity.
    * apply f_inj in H.
      rewrite <- H.
      assumption.
  + intro.
    destruct finv_noteven.
    simpl.
    apply f_inj.
    assumption.
Qed.

Lemma CSB_comp2: forall y:Y, CSB_bijection (CSB_bijection2 y) = y.
Proof.
intro.
unfold CSB_bijection2; case (classic_dec (Y_even y)).
- intro.
  unfold CSB_bijection; case (classic_dec (X_odd (g y))).
  + intro.
    destruct ginv_odd.
    simpl.
    apply g_inj.
    assumption.
  + intro.
    contradict n.
    constructor.
    assumption.
- intro.
  destruct finv_noteven.
  simpl.
  unfold CSB_bijection; case (classic_dec (X_odd x)).
  + intro.
    contradict n.
    rewrite <- e.
    constructor 2.
    assumption.
  + trivial.
Qed.

Theorem CSB: exists h:X->Y, bijective h.
Proof.
exists CSB_bijection.
apply invertible_impl_bijective.
exists CSB_bijection2.
- exact CSB_comp1.
- exact CSB_comp2.
Qed.

End CSB.


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

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

(** * Type [Z] viewed modulo a particular constant corresponds to [Z/nZ]
      as defined abstractly in CyclicAxioms. *)

(** Even if the construction provided here is not reused for building
  the efficient arbitrary precision numbers, it provides a simple
  implementation of CyclicAxioms, hence ensuring its coherence. *)

Set Implicit Arguments.

Require Import Bool.
Require Import ZArith.
Require Import Znumtheory.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import CyclicAxioms.

Local Open Scope Z_scope.

Section ZModulo.

 Variable digits : positive.
 Hypothesis digits_ne_1 : digits <> 1%positive.

 Definition wB := base digits.

 Definition znz := Z.
 Definition znz_digits := digits.
 Definition znz_zdigits := Zpos digits.
 Definition znz_to_Z x := x mod wB.

 Notation "[| x |]" := (znz_to_Z x)  (at level 0, x at level 99).

 Notation "[+| c |]" :=
   (interp_carry 1 wB znz_to_Z c)  (at level 0, x at level 99).

 Notation "[-| c |]" :=
   (interp_carry (-1) wB znz_to_Z c)  (at level 0, x at level 99).

 Notation "[|| x ||]" :=
   (zn2z_to_Z wB znz_to_Z x)  (at level 0, x at level 99).

 Lemma spec_more_than_1_digit: 1 < Zpos digits.
 Proof.
  unfold znz_digits.
  generalize digits_ne_1; destruct digits; auto.
  destruct 1; auto.
 Qed.
 Let digits_gt_1 := spec_more_than_1_digit.

 Lemma wB_pos : wB > 0.
 Proof.
  unfold wB, base; auto with zarith.
 Qed.
 Hint Resolve wB_pos.

 Lemma spec_to_Z_1 : forall x, 0 <= [|x|].
 Proof.
  unfold znz_to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
 Qed.

 Lemma spec_to_Z_2 : forall x, [|x|] < wB.
 Proof.
  unfold znz_to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto.
 Qed.
 Hint Resolve spec_to_Z_1 spec_to_Z_2.

 Lemma spec_to_Z : forall x, 0 <= [|x|] < wB.
 Proof.
  auto.
 Qed.

 Definition znz_of_pos x :=
   let (q,r) := Zdiv_eucl_POS x wB in (N_of_Z q, r).

 Lemma spec_of_pos : forall p,
   Zpos p = (Z_of_N (fst (znz_of_pos p)))*wB + [|(snd (znz_of_pos p))|].
 Proof.
  intros; unfold znz_of_pos; simpl.
  generalize (Z_div_mod_POS wB wB_pos p).
  destruct (Zdiv_eucl_POS p wB); simpl; destruct 1.
  unfold znz_to_Z; rewrite Zmod_small; auto.
  assert (0 <= z).
   replace z with (Zpos p / wB) by
    (symmetry; apply Zdiv_unique with z0; auto).
   apply Z_div_pos; auto with zarith.
  replace (Z_of_N (N_of_Z z)) with z by
    (destruct z; simpl; auto; elim H1; auto).
  rewrite Zmult_comm; auto.
 Qed.

 Lemma spec_zdigits : [|znz_zdigits|] = Zpos znz_digits.
 Proof.
  unfold znz_to_Z, znz_zdigits, znz_digits.
  apply Zmod_small.
  unfold wB, base.
  split; auto with zarith.
  apply Zpower2_lt_lin; auto with zarith.
 Qed.

 Definition znz_0 := 0.
 Definition znz_1 := 1.
 Definition znz_Bm1 := wB - 1.

 Lemma spec_0 : [|znz_0|] = 0.
 Proof.
  unfold znz_to_Z, znz_0.
  apply Zmod_small; generalize wB_pos; auto with zarith.
 Qed.

 Lemma spec_1 : [|znz_1|] = 1.
 Proof.
  unfold znz_to_Z, znz_1.
  apply Zmod_small; split; auto with zarith.
  unfold wB, base.
  apply Zlt_trans with (Zpos digits); auto.
  apply Zpower2_lt_lin; auto with zarith.
 Qed.

 Lemma spec_Bm1 : [|znz_Bm1|] = wB - 1.
 Proof.
  unfold znz_to_Z, znz_Bm1.
  apply Zmod_small; split; auto with zarith.
  unfold wB, base.
  cut (1 <= 2 ^ Zpos digits); auto with zarith.
  apply Zle_trans with (Zpos digits); auto with zarith.
  apply Zpower2_le_lin; auto with zarith.
 Qed.

 Definition znz_compare x y := Zcompare [|x|] [|y|].

 Lemma spec_compare : forall x y,
       match znz_compare x y with
       | Eq => [|x|] = [|y|]
       | Lt => [|x|] < [|y|]
       | Gt => [|x|] > [|y|]
       end.
 Proof.
  intros; unfold znz_compare, Zlt, Zgt.
  case_eq (Zcompare [|x|] [|y|]); auto.
  intros; apply Zcompare_Eq_eq; auto.
 Qed.

 Definition znz_eq0 x :=
   match [|x|] with Z0 => true | _ => false end.

 Lemma spec_eq0 : forall x, znz_eq0 x = true -> [|x|] = 0.
 Proof.
  unfold znz_eq0; intros; now destruct [|x|].
 Qed.

 Definition znz_opp_c x :=
   if znz_eq0 x then C0 0 else C1 (- x).
 Definition znz_opp x := - x.
 Definition znz_opp_carry x := - x - 1.

 Lemma spec_opp_c : forall x, [-|znz_opp_c x|] = -[|x|].
 Proof.
 intros; unfold znz_opp_c, znz_to_Z; auto.
 case_eq (znz_eq0 x); intros; unfold interp_carry.
 fold [|x|]; rewrite (spec_eq0 x H); auto.
 assert (x mod wB <> 0).
  unfold znz_eq0, znz_to_Z in H.
  intro H0; rewrite H0 in H; discriminate.
 rewrite Z_mod_nz_opp_full; auto with zarith.
 Qed.

 Lemma spec_opp : forall x, [|znz_opp x|] = (-[|x|]) mod wB.
 Proof.
 intros; unfold znz_opp, znz_to_Z; auto.
 change ((- x) mod wB = (0 - (x mod wB)) mod wB).
 rewrite Zminus_mod_idemp_r; simpl; auto.
 Qed.

 Lemma spec_opp_carry : forall x, [|znz_opp_carry x|] = wB - [|x|] - 1.
 Proof.
 intros; unfold znz_opp_carry, znz_to_Z; auto.
 replace (- x - 1) with (- 1 - x) by omega.
 rewrite <- Zminus_mod_idemp_r.
 replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by omega.
 rewrite <- (Z_mod_same_full wB).
 rewrite Zplus_mod_idemp_l.
 replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by omega.
 apply Zmod_small.
 generalize (Z_mod_lt x wB wB_pos); omega.
 Qed.

 Definition znz_succ_c x :=
  let y := Zsucc x in
  if znz_eq0 y then C1 0 else C0 y.

 Definition znz_add_c x y :=
  let z := [|x|] + [|y|] in
  if Z_lt_le_dec z wB then C0 z else C1 (z-wB).

 Definition znz_add_carry_c x y :=
  let z := [|x|]+[|y|]+1 in
  if Z_lt_le_dec z wB then C0 z else C1 (z-wB).

 Definition znz_succ := Zsucc.
 Definition znz_add := Zplus.
 Definition znz_add_carry x y := x + y + 1.

 Lemma Zmod_equal :
  forall x y z, z>0 -> (x-y) mod z = 0 -> x mod z = y mod z.
 Proof.
 intros.
 generalize (Z_div_mod_eq (x-y) z H); rewrite H0, Zplus_0_r.
 remember ((x-y)/z) as k.
 intros H1; symmetry in H1; rewrite <- Zeq_plus_swap in H1.
 subst x.
 rewrite Zplus_comm, Zmult_comm, Z_mod_plus; auto.
 Qed.

 Lemma spec_succ_c : forall x, [+|znz_succ_c x|] = [|x|] + 1.
 Proof.
 intros; unfold znz_succ_c, znz_to_Z, Zsucc.
 case_eq (znz_eq0 (x+1)); intros; unfold interp_carry.

 rewrite Zmult_1_l.
 replace (wB + 0 mod wB) with wB by auto with zarith.
 symmetry; rewrite Zeq_plus_swap.
 assert ((x+1) mod wB = 0) by (apply spec_eq0; auto).
 replace (wB-1) with ((wB-1) mod wB) by
  (apply Zmod_small; generalize wB_pos; omega).
 rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto.
 apply Zmod_equal; auto.

 assert ((x+1) mod wB <> 0).
  unfold znz_eq0, znz_to_Z in *; now destruct ((x+1) mod wB).
 assert (x mod wB + 1 <> wB).
  contradict H0.
  rewrite Zeq_plus_swap in H0; simpl in H0.
  rewrite <- Zplus_mod_idemp_l; rewrite H0.
  replace (wB-1+1) with wB; auto with zarith; apply Z_mod_same; auto.
 rewrite <- Zplus_mod_idemp_l.
 apply Zmod_small.
 generalize (Z_mod_lt x wB wB_pos); omega.
 Qed.

 Lemma spec_add_c : forall x y, [+|znz_add_c x y|] = [|x|] + [|y|].
 Proof.
 intros; unfold znz_add_c, znz_to_Z, interp_carry.
 destruct Z_lt_le_dec.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 rewrite Zmult_1_l, Zplus_comm, Zeq_plus_swap.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_add_carry_c : forall x y, [+|znz_add_carry_c x y|] = [|x|] + [|y|] + 1.
 Proof.
 intros; unfold znz_add_carry_c, znz_to_Z, interp_carry.
 destruct Z_lt_le_dec.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 rewrite Zmult_1_l, Zplus_comm, Zeq_plus_swap.
 apply Zmod_small;
  generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_succ : forall x, [|znz_succ x|] = ([|x|] + 1) mod wB.
 Proof.
 intros; unfold znz_succ, znz_to_Z, Zsucc.
 symmetry; apply Zplus_mod_idemp_l.
 Qed.

 Lemma spec_add : forall x y, [|znz_add x y|] = ([|x|] + [|y|]) mod wB.
 Proof.
 intros; unfold znz_add, znz_to_Z; apply Zplus_mod.
 Qed.

 Lemma spec_add_carry :
	 forall x y, [|znz_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB.
 Proof.
 intros; unfold znz_add_carry, znz_to_Z.
 rewrite <- Zplus_mod_idemp_l.
 rewrite (Zplus_mod x y).
 rewrite Zplus_mod_idemp_l; auto.
 Qed.

 Definition znz_pred_c x :=
  if znz_eq0 x then C1 (wB-1) else C0 (x-1).

 Definition znz_sub_c x y :=
  let z := [|x|]-[|y|] in
  if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.

 Definition znz_sub_carry_c x y :=
  let z := [|x|]-[|y|]-1 in
  if Z_lt_le_dec z 0 then C1 (wB+z) else C0 z.

 Definition znz_pred := Zpred.
 Definition znz_sub := Zminus.
 Definition znz_sub_carry x y := x - y - 1.

 Lemma spec_pred_c : forall x, [-|znz_pred_c x|] = [|x|] - 1.
 Proof.
 intros; unfold znz_pred_c, znz_to_Z, interp_carry.
 case_eq (znz_eq0 x); intros.
 fold [|x|]; rewrite spec_eq0; auto.
 replace ((wB-1) mod wB) with (wB-1); auto with zarith.
 symmetry; apply Zmod_small; generalize wB_pos; omega.

 assert (x mod wB <> 0).
  unfold znz_eq0, znz_to_Z in *; now destruct (x mod wB).
 rewrite <- Zminus_mod_idemp_l.
 apply Zmod_small.
 generalize (Z_mod_lt x wB wB_pos); omega.
 Qed.

 Lemma spec_sub_c : forall x y, [-|znz_sub_c x y|] = [|x|] - [|y|].
 Proof.
 intros; unfold znz_sub_c, znz_to_Z, interp_carry.
 destruct Z_lt_le_dec.
 replace ((wB + (x mod wB - y mod wB)) mod wB) with
   (wB + (x mod wB - y mod wB)).
 omega.
 symmetry; apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.

 apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_sub_carry_c : forall x y, [-|znz_sub_carry_c x y|] = [|x|] - [|y|] - 1.
 Proof.
 intros; unfold znz_sub_carry_c, znz_to_Z, interp_carry.
 destruct Z_lt_le_dec.
 replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with
   (wB + (x mod wB - y mod wB -1)).
 omega.
 symmetry; apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.

 apply Zmod_small.
 generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega.
 Qed.

 Lemma spec_pred : forall x, [|znz_pred x|] = ([|x|] - 1) mod wB.
 Proof.
 intros; unfold znz_pred, znz_to_Z, Zpred.
 rewrite <- Zplus_mod_idemp_l; auto.
 Qed.

 Lemma spec_sub : forall x y, [|znz_sub x y|] = ([|x|] - [|y|]) mod wB.
 Proof.
 intros; unfold znz_sub, znz_to_Z; apply Zminus_mod.
 Qed.

 Lemma spec_sub_carry :
  forall x y, [|znz_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB.
 Proof.
 intros; unfold znz_sub_carry, znz_to_Z.
 rewrite <- Zminus_mod_idemp_l.
 rewrite (Zminus_mod x y).
 rewrite Zminus_mod_idemp_l.
 auto.
 Qed.

 Definition znz_mul_c x y :=
  let (h,l) := Zdiv_eucl ([|x|]*[|y|]) wB in
  if znz_eq0 h then if znz_eq0 l then W0 else WW h l else WW h l.

 Definition znz_mul := Zmult.

 Definition znz_square_c x := znz_mul_c x x.

 Lemma spec_mul_c : forall x y, [|| znz_mul_c x y ||] = [|x|] * [|y|].
 Proof.
 intros; unfold znz_mul_c, zn2z_to_Z.
 assert (Zdiv_eucl ([|x|]*[|y|]) wB = (([|x|]*[|y|])/wB,([|x|]*[|y|]) mod wB)).
  unfold Zmod, Zdiv; destruct Zdiv_eucl; auto.
 generalize (Z_div_mod ([|x|]*[|y|]) wB wB_pos); destruct Zdiv_eucl as (h,l).
 destruct 1; injection H; clear H; intros.
 rewrite H0.
 assert ([|l|] = l).
  apply Zmod_small; auto.
 assert ([|h|] = h).
  apply Zmod_small.
  subst h.
  split.
  apply Z_div_pos; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
  apply Zmult_lt_compat; auto with zarith.
 clear H H0 H1 H2.
 case_eq (znz_eq0 h); simpl; intros.
 case_eq (znz_eq0 l); simpl; intros.
 rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto with zarith.
 rewrite H3, H4; auto with zarith.
 rewrite H3, H4; auto with zarith.
 Qed.

 Lemma spec_mul : forall x y, [|znz_mul x y|] = ([|x|] * [|y|]) mod wB.
 Proof.
 intros; unfold znz_mul, znz_to_Z; apply Zmult_mod.
 Qed.

 Lemma spec_square_c : forall x, [|| znz_square_c x||] = [|x|] * [|x|].
 Proof.
 intros x; exact (spec_mul_c x x).
 Qed.

 Definition znz_div x y := Zdiv_eucl [|x|] [|y|].

 Lemma spec_div : forall a b, 0 < [|b|] ->
      let (q,r) := znz_div a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
 intros; unfold znz_div.
 assert ([|b|]>0) by auto with zarith.
 assert (Zdiv_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])).
  unfold Zmod, Zdiv; destruct Zdiv_eucl; auto.
 generalize (Z_div_mod [|a|] [|b|] H0).
 destruct Zdiv_eucl as (q,r); destruct 1; intros.
 injection H1; clear H1; intros.
 assert ([|r|]=r).
  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
   auto with zarith.
 assert ([|q|]=q).
  apply Zmod_small.
  subst q.
  split.
  apply Z_div_pos; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
  apply Zlt_le_trans with (wB*1).
  rewrite Zmult_1_r; auto with zarith.
  apply Zmult_le_compat; generalize wB_pos; auto with zarith.
 rewrite H5, H6; rewrite Zmult_comm; auto with zarith.
 Qed.

 Definition znz_div_gt := znz_div.

 Lemma spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      let (q,r) := znz_div_gt a b in
      [|a|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
 intros.
 apply spec_div; auto.
 Qed.

 Definition znz_mod x y := [|x|] mod [|y|].
 Definition znz_mod_gt x y := [|x|] mod [|y|].

 Lemma spec_mod :  forall a b, 0 < [|b|] ->
      [|znz_mod a b|] = [|a|] mod [|b|].
 Proof.
 intros; unfold znz_mod.
 apply Zmod_small.
 assert ([|b|]>0) by auto with zarith.
 generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos).
 fold [|b|]; omega.
 Qed.

 Lemma spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] ->
      [|znz_mod_gt a b|] = [|a|] mod [|b|].
 Proof.
 intros; apply spec_mod; auto.
 Qed.

 Definition znz_gcd x y := Zgcd [|x|] [|y|].
 Definition znz_gcd_gt x y := Zgcd [|x|] [|y|].

 Lemma Zgcd_bound : forall a b, 0<=a -> 0<=b -> Zgcd a b <= Zmax a b.
 Proof.
 intros.
 generalize (Zgcd_is_gcd a b); inversion_clear 1.
 destruct H2; destruct H3; clear H4.
 assert (H3:=Zgcd_is_pos a b).
 destruct (Z_eq_dec (Zgcd a b) 0).
 rewrite e; generalize (Zmax_spec a b); omega.
 assert (0 <= q).
  apply Zmult_le_reg_r with (Zgcd a b); auto with zarith.
 destruct (Z_eq_dec q 0).

 subst q; simpl in *; subst a; simpl; auto.
 generalize (Zmax_spec 0 b) (Zabs_spec b); omega.

 apply Zle_trans with a.
 rewrite H1 at 2.
 rewrite <- (Zmult_1_l (Zgcd a b)) at 1.
 apply Zmult_le_compat; auto with zarith.
 generalize (Zmax_spec a b); omega.
 Qed.

 Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|znz_gcd a b|].
 Proof.
 intros; unfold znz_gcd.
 generalize (Z_mod_lt a wB wB_pos)(Z_mod_lt b wB wB_pos); intros.
 fold [|a|] in *; fold [|b|] in *.
 replace ([|Zgcd [|a|] [|b|]|]) with (Zgcd [|a|] [|b|]).
 apply Zgcd_is_gcd.
 symmetry; apply Zmod_small.
 split.
 apply Zgcd_is_pos.
 apply Zle_lt_trans with (Zmax [|a|] [|b|]).
 apply Zgcd_bound; auto with zarith.
 generalize (Zmax_spec [|a|] [|b|]); omega.
 Qed.

 Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] ->
      Zis_gcd [|a|] [|b|] [|znz_gcd_gt a b|].
 Proof.
  intros. apply spec_gcd; auto.
 Qed.

 Definition znz_div21 a1 a2 b :=
  Zdiv_eucl ([|a1|]*wB+[|a2|]) [|b|].

 Lemma spec_div21 : forall a1 a2 b,
      wB/2 <= [|b|] ->
      [|a1|] < [|b|] ->
      let (q,r) := znz_div21 a1 a2 b in
      [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\
      0 <= [|r|] < [|b|].
 Proof.
 intros; unfold znz_div21.
 generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros.
 generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros.
 assert ([|b|]>0) by auto with zarith.
 remember ([|a1|]*wB+[|a2|]) as a.
 assert (Zdiv_eucl a [|b|] = (a/[|b|], a mod [|b|])).
  unfold Zmod, Zdiv; destruct Zdiv_eucl; auto.
 generalize (Z_div_mod a [|b|] H3).
 destruct Zdiv_eucl as (q,r); destruct 1; intros.
 injection H4; clear H4; intros.
 assert ([|r|]=r).
  apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|];
   auto with zarith.
 assert ([|q|]=q).
  apply Zmod_small.
  subst q.
  split.
  apply Z_div_pos; auto with zarith.
  subst a; auto with zarith.
  apply Zdiv_lt_upper_bound; auto with zarith.
  subst a.
  replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring.
  apply Zlt_le_trans with ([|a1|]*wB+wB); auto with zarith.
 rewrite H8, H9; rewrite Zmult_comm; auto with zarith.
 Qed.

 Definition znz_add_mul_div p x y :=
   ([|x|] * (2 ^ [|p|]) + [|y|] / (2 ^ ((Zpos znz_digits) - [|p|]))).
 Lemma spec_add_mul_div : forall x y p,
       [|p|] <= Zpos znz_digits ->
       [| znz_add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos znz_digits) - [|p|]))) mod wB.
 Proof.
 intros; unfold znz_add_mul_div; auto.
 Qed.

 Definition znz_pos_mod p w := [|w|] mod (2 ^ [|p|]).
 Lemma spec_pos_mod : forall w p,
       [|znz_pos_mod p w|] = [|w|] mod (2 ^ [|p|]).
 Proof.
 intros; unfold znz_pos_mod.
 apply Zmod_small.
 generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros.
 split.
 destruct H; auto with zarith.
 apply Zle_lt_trans with [|w|]; auto with zarith.
 apply Zmod_le; auto with zarith.
 Qed.

 Definition znz_is_even x :=
   if Z_eq_dec ([|x|] mod 2) 0 then true else false.

 Lemma spec_is_even : forall x,
      if znz_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1.
 Proof.
 intros; unfold znz_is_even; destruct Z_eq_dec; auto.
 generalize (Z_mod_lt [|x|] 2); omega.
 Qed.

 Definition znz_sqrt x := Zsqrt_plain [|x|].
 Lemma spec_sqrt : forall x,
       [|znz_sqrt x|] ^ 2 <= [|x|] < ([|znz_sqrt x|] + 1) ^ 2.
 Proof.
 intros.
 unfold znz_sqrt.
 repeat rewrite Zpower_2.
 replace [|Zsqrt_plain [|x|]|] with (Zsqrt_plain [|x|]).
 apply Zsqrt_interval; auto with zarith.
 symmetry; apply Zmod_small.
 split.
 apply Zsqrt_plain_is_pos; auto with zarith.

 cut (Zsqrt_plain [|x|] <= (wB-1)); try omega.
 rewrite <- (Zsqrt_square_id (wB-1)).
 apply Zsqrt_le.
 split; auto.
 apply Zle_trans with (wB-1); auto with zarith.
 generalize (spec_to_Z x); auto with zarith.
 apply Zsquare_le.
 generalize wB_pos; auto with zarith.
 Qed.

 Definition znz_sqrt2 x y :=
  let z := [|x|]*wB+[|y|] in
  match z with
   | Z0 => (0, C0 0)
   | Zpos p =>
      let (s,r,_,_) := sqrtrempos p in
      (s, if Z_lt_le_dec r wB then C0 r else C1 (r-wB))
   | Zneg _ => (0, C0 0)
  end.

 Lemma spec_sqrt2 : forall x y,
       wB/ 4 <= [|x|] ->
       let (s,r) := znz_sqrt2 x y in
          [||WW x y||] = [|s|] ^ 2 + [+|r|] /\
          [+|r|] <= 2 * [|s|].
 Proof.
 intros; unfold znz_sqrt2.
 simpl zn2z_to_Z.
 remember ([|x|]*wB+[|y|]) as z.
 destruct z.
 auto with zarith.
 destruct sqrtrempos; intros.
 assert (s < wB).
  destruct (Z_lt_le_dec s wB); auto.
  assert (wB * wB <= Zpos p).
   rewrite e.
   apply Zle_trans with (s*s); try omega.
   apply Zmult_le_compat; generalize wB_pos; auto with zarith.
  assert (Zpos p < wB*wB).
   rewrite Heqz.
   replace (wB*wB) with ((wB-1)*wB+wB) by ring.
   apply Zplus_le_lt_compat; auto with zarith.
   apply Zmult_le_compat; auto with zarith.
   generalize (spec_to_Z x); auto with zarith.
   generalize wB_pos; auto with zarith.
  omega.
 replace [|s|] with s by (symmetry; apply Zmod_small; auto with zarith).
 destruct Z_lt_le_dec; unfold interp_carry.
 replace [|r|] with r by (symmetry; apply Zmod_small; auto with zarith).
 rewrite Zpower_2; auto with zarith.
 replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith).
 rewrite Zpower_2; omega.

 assert (0<=Zneg p).
  rewrite Heqz; generalize wB_pos; auto with zarith.
 compute in H0; elim H0; auto.
 Qed.

 Lemma two_p_power2 : forall x, x>=0 -> two_p x = 2 ^ x.
 Proof.
 intros.
 unfold two_p.
 destruct x; simpl; auto.
 apply two_power_pos_correct.
 Qed.

 Definition znz_head0 x := match [|x|] with
   | Z0 => znz_zdigits
   | Zpos p => znz_zdigits - log_inf p - 1
   | _ => 0
  end.

 Lemma spec_head00:  forall x, [|x|] = 0 -> [|znz_head0 x|] = Zpos znz_digits.
 Proof.
  unfold znz_head0; intros.
  rewrite H; simpl.
  apply spec_zdigits.
 Qed.

 Lemma log_inf_bounded : forall x p, Zpos x < 2^p -> log_inf x < p.
 Proof.
 induction x; simpl; intros.

 assert (0 < p) by (destruct p; compute; auto with zarith; discriminate).
 cut (log_inf x < p - 1); [omega| ].
 apply IHx.
 change (Zpos x~1) with (2*(Zpos x)+1) in H.
 replace p with (Zsucc (p-1)) in H; auto with zarith.
 rewrite Zpower_Zsucc in H; auto with zarith.

 assert (0 < p) by (destruct p; compute; auto with zarith; discriminate).
 cut (log_inf x < p - 1); [omega| ].
 apply IHx.
 change (Zpos x~0) with (2*(Zpos x)) in H.
 replace p with (Zsucc (p-1)) in H; auto with zarith.
 rewrite Zpower_Zsucc in H; auto with zarith.

 simpl; intros; destruct p; compute; auto with zarith.
 Qed.

 Lemma spec_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ ([|znz_head0 x|]) * [|x|] < wB.
 Proof.
 intros; unfold znz_head0.
 generalize (spec_to_Z x).
 destruct [|x|]; try discriminate.
 intros.
 destruct (log_inf_correct p).
 rewrite 2 two_p_power2 in H2; auto with zarith.
 assert (0 <= znz_zdigits - log_inf p - 1 < wB).
  split.
  cut (log_inf p < znz_zdigits); try omega.
  unfold znz_zdigits.
  unfold wB, base in *.
  apply log_inf_bounded; auto with zarith.
  apply Zlt_trans with znz_zdigits.
  omega.
  unfold znz_zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith.

 unfold znz_to_Z; rewrite (Zmod_small _ _ H3).
 destruct H2.
 split.
 apply Zle_trans with (2^(znz_zdigits - log_inf p - 1)*(2^log_inf p)).
 apply Zdiv_le_upper_bound; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 rewrite Zmult_comm; rewrite <- Zpower_Zsucc; auto with zarith.
 replace (Zsucc (znz_zdigits - log_inf p -1 +log_inf p)) with znz_zdigits
   by ring.
 unfold wB, base, znz_zdigits; auto with zarith.
 apply Zmult_le_compat; auto with zarith.

 apply Zlt_le_trans
   with (2^(znz_zdigits - log_inf p - 1)*(2^(Zsucc (log_inf p)))).
 apply Zmult_lt_compat_l; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 replace (znz_zdigits - log_inf p -1 +Zsucc (log_inf p)) with znz_zdigits
   by ring.
 unfold wB, base, znz_zdigits; auto with zarith.
 Qed.

 Fixpoint Ptail p := match p with
  | xO p => (Ptail p)+1
  | _ => 0
 end.

 Lemma Ptail_pos : forall p, 0 <= Ptail p.
 Proof.
 induction p; simpl; auto with zarith.
 Qed.
 Hint Resolve Ptail_pos.

 Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d.
 Proof.
 induction p; try (compute; auto; fail).
 intros; simpl.
 assert (d <> xH).
  intro; subst.
  compute in H; destruct p; discriminate.
 assert (Zsucc (Zpos (Ppred d)) = Zpos d).
  simpl; f_equal.
  rewrite <- Pplus_one_succ_r.
  destruct (Psucc_pred d); auto.
  rewrite H1 in H0; elim H0; auto.
 assert (Ptail p < Zpos (Ppred d)).
  apply IHp.
  apply Zmult_lt_reg_r with 2; auto with zarith.
  rewrite (Zmult_comm (Zpos p)).
  change (2 * Zpos p) with (Zpos p~0).
  rewrite Zmult_comm.
  rewrite <- Zpower_Zsucc; auto with zarith.
  rewrite H1; auto.
 rewrite <- H1; omega.
 Qed.

 Definition znz_tail0 x :=
  match [|x|] with
   | Z0 => znz_zdigits
   | Zpos p => Ptail p
   | Zneg _ => 0
  end.

 Lemma spec_tail00:  forall x, [|x|] = 0 -> [|znz_tail0 x|] = Zpos znz_digits.
 Proof.
  unfold znz_tail0; intros.
  rewrite H; simpl.
  apply spec_zdigits.
 Qed.

 Lemma spec_tail0  : forall x, 0 < [|x|] ->
         exists y, 0 <= y /\ [|x|] = (2 * y + 1) * (2 ^ [|znz_tail0 x|]).
 Proof.
 intros; unfold znz_tail0.
 generalize (spec_to_Z x).
 destruct [|x|]; try discriminate; intros.
 assert ([|Ptail p|] = Ptail p).
  apply Zmod_small.
  split; auto.
  unfold wB, base in *.
  apply Zlt_trans with (Zpos digits).
  apply Ptail_bounded; auto with zarith.
  apply Zpower2_lt_lin; auto with zarith.
 rewrite H1.

 clear; induction p.
 exists (Zpos p); simpl; rewrite Pmult_1_r; auto with zarith.
 destruct IHp as (y & Yp & Ye).
 exists y.
 split; auto.
 change (Zpos p~0) with (2*Zpos p).
 rewrite Ye.
 change (Ptail p~0) with (Zsucc (Ptail p)).
 rewrite Zpower_Zsucc; auto; ring.

 exists 0; simpl; auto with zarith.
 Qed.

 (** Let's now group everything in two records *)

 Definition zmod_op := mk_znz_op
    (znz_digits : positive)
    (znz_zdigits: znz)
    (znz_to_Z   : znz -> Z)
    (znz_of_pos : positive -> N * znz)
    (znz_head0  : znz -> znz)
    (znz_tail0  : znz -> znz)

    (znz_0   : znz)
    (znz_1   : znz)
    (znz_Bm1 : znz)

    (znz_compare     : znz -> znz -> comparison)
    (znz_eq0         : znz -> bool)

    (znz_opp_c       : znz -> carry znz)
    (znz_opp         : znz -> znz)
    (znz_opp_carry   : znz -> znz)

    (znz_succ_c      : znz -> carry znz)
    (znz_add_c       : znz -> znz -> carry znz)
    (znz_add_carry_c : znz -> znz -> carry znz)
    (znz_succ        : znz -> znz)
    (znz_add         : znz -> znz -> znz)
    (znz_add_carry   : znz -> znz -> znz)

    (znz_pred_c      : znz -> carry znz)
    (znz_sub_c       : znz -> znz -> carry znz)
    (znz_sub_carry_c : znz -> znz -> carry znz)
    (znz_pred        : znz -> znz)
    (znz_sub         : znz -> znz -> znz)
    (znz_sub_carry   : znz -> znz -> znz)

    (znz_mul_c       : znz -> znz -> zn2z znz)
    (znz_mul         : znz -> znz -> znz)
    (znz_square_c    : znz -> zn2z znz)

    (znz_div21       : znz -> znz -> znz -> znz*znz)
    (znz_div_gt      : znz -> znz -> znz * znz)
    (znz_div         : znz -> znz -> znz * znz)

    (znz_mod_gt      : znz -> znz -> znz)
    (znz_mod         : znz -> znz -> znz)

    (znz_gcd_gt      : znz -> znz -> znz)
    (znz_gcd         : znz -> znz -> znz)
    (znz_add_mul_div : znz -> znz -> znz -> znz)
    (znz_pos_mod     : znz -> znz -> znz)

    (znz_is_even     : znz -> bool)
    (znz_sqrt2       : znz -> znz -> znz * carry znz)
    (znz_sqrt        : znz -> znz).

 Definition zmod_spec := mk_znz_spec zmod_op
    spec_to_Z
    spec_of_pos
    spec_zdigits
    spec_more_than_1_digit

    spec_0
    spec_1
    spec_Bm1

    spec_compare
    spec_eq0

    spec_opp_c
    spec_opp
    spec_opp_carry

    spec_succ_c
    spec_add_c
    spec_add_carry_c
    spec_succ
    spec_add
    spec_add_carry

    spec_pred_c
    spec_sub_c
    spec_sub_carry_c
    spec_pred
    spec_sub
    spec_sub_carry

    spec_mul_c
    spec_mul
    spec_square_c

    spec_div21
    spec_div_gt
    spec_div

    spec_mod_gt
    spec_mod

    spec_gcd_gt
    spec_gcd

    spec_head00
    spec_head0
    spec_tail00
    spec_tail0

    spec_add_mul_div
    spec_pos_mod

    spec_is_even
    spec_sqrt2
    spec_sqrt.

End ZModulo.

(** A modular version of the previous construction. *)

Module Type PositiveNotOne.
 Parameter p : positive.
 Axiom not_one : p<> 1%positive.
End PositiveNotOne.

Module ZModuloCyclicType (P:PositiveNotOne) <: CyclicType.
 Definition w := Z.
 Definition w_op := zmod_op P.p.
 Definition w_spec := zmod_spec P.not_one.
End ZModuloCyclicType.


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

End FOFProblem.


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 Aprime Bprime Cprime Bprimeprime Cprimeprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Aprime Cprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Bprimeprime Cprime /\ (wd_ Aprime Cprime /\ (wd_ Aprime Bprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Cprimeprime /\ (wd_ Aprime Cprimeprime /\ (col_ A B C /\ (col_ Aprime Cprime Bprimeprime /\ (col_ Aprime Bprimeprime Cprime /\ (col_ Aprime Bprime Cprimeprime /\ col_ Bprime Cprimeprime Cprime))))))))))))))))) -> col_ Aprime Bprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj28synthconj1_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv1 lv0) lv1) lv2) ->  (@eq natural (Succ (plus (plus Zero (mult lv0 lv1)) (plus lv0 lv1))) (plus lv2 (Succ lv0))).
Admitted.
QuickChick conj28synthconj1_hyp.