(*
 - Some auxiliary lemmas
 - Definition of 'DFcell'
From 'UniMath/Bicategories/DisplayedBicats/Examples/Add2Cell.v' and 'UniMath/Bicategories/Core/BicategoryLaws.v'
 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.

Require Import Integers.Prebicategories.DispPrebicat.
Require Import Integers.Prebicategories.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import Integers.Prebicategories.PseudoTransformation.
Require Import Integers.Prebicategories.Composition.
Require Import Integers.Prebicategories.Identity.
Require Import Integers.Prebicategories.Projection.

Local Open Scope cat.
Local Open Scope mor_disp_scope.
Local Open Scope bicategory_scope.

(** Auxiliary lemmas **)
Definition linvunitor_natural
           {C : prebicat}
           {X Y : C}
           {f g : C⟦X, Y⟧}
           (η : f ==> g)
  : linvunitor g o η = (η ⋆⋆ id₂ (id₁ X)) o linvunitor f.
Proof.
  use (vcomp_rcancel (lunitor _ )).
  { apply is_invertible_2cell_lunitor. }
  rewrite vassocl.
  rewrite linvunitor_lunitor.
  use (vcomp_lcancel (lunitor _ )).
  { apply is_invertible_2cell_lunitor. }
  repeat rewrite vassocr.
  rewrite lunitor_linvunitor.
  rewrite id2_left, id2_right.
  apply (! lunitor_natural _ _ _ _ _ ).
Qed.

Definition lwhisker_hcomp
           {C : prebicat}
           {X Y Z : C}
           {f g : C⟦Y,Z⟧}
           (h : C⟦X, Y⟧)
           (α : f ==> g)
  : h ◃ α = id₂ h ⋆ α.
Proof.
  unfold hcomp.
  rewrite id2_rwhisker.
  rewrite id2_left.
  reflexivity.
Qed.

(** Definition of DFcell **)
Section AddEndpoints.
  Context {C : prebicat}.
  Variable (D : disp_prebicat C).

  Variable (S T : pseudofunctor C C).
  Variable (l r : pseudotrans
                    (comp_pseudofunctor S (pr1_pseudofunctor D))
                    (comp_pseudofunctor T (pr1_pseudofunctor D))).

  Definition add_path_endpoints_ob_mor : Core.disp_cat_ob_mor (total_prebicat D).
  Proof.
    use tpair.
    - exact (λ Aa, l Aa ==> r Aa).
    - intros Aa Bb α β ff.
      exact ((α ▹ (#T (#(pr1_pseudofunctor D) ff))) • pseudonaturality_of r ff
             = (pseudonaturality_of l ff) • (#S (#(pr1_pseudofunctor D) ff) ◃ β)).
  Defined.

  Definition add_path_endpoints_id_comp
    : Core.disp_cat_id_comp (total_prebicat D) add_path_endpoints_ob_mor.
  Proof.
    split.
    - intros x xx.
      pose (pseudotrans_id_alt l x) as p.
      simpl.
      cbn in p.
      rewrite !pseudofunctor_id2 in p.
      rewrite id2_left, id2_right in p.
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        exact p.
      }
      clear p.
      refine (!_).
      pose (pseudotrans_id_alt r x) as p.
      cbn in p.
      rewrite !pseudofunctor_id2 in p.
      rewrite id2_left, id2_right in p.
      etrans.
      {
        apply maponpaths.
        exact p.
      }
      clear p.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_runitor.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite linvunitor_natural.
      rewrite <- lwhisker_hcomp.
      rewrite !vassocl.
      rewrite vcomp_whisker.
      apply idpath.
    - intros x y z f g xx yy zz Hf Hg ; cbn.
      pose (pseudotrans_comp_alt l f g) as pl.
      pose (pseudotrans_comp_alt r f g) as pr.
      cbn in pl, pr ; rewrite pl, pr ; clear pl pr.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite vcomp_whisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- lwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_vcomp.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths_2.
        apply maponpaths.
        apply Hf.
      }
      rewrite <- rwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite lwhisker_vcomp.
      etrans.
      {
        apply maponpaths.
        apply Hg.
      }
      rewrite <- lwhisker_vcomp.
      reflexivity.
  Qed.

  Definition add_path_endpoints_1_id_comp_cells : disp_prebicat_1_id_comp_cells (total_prebicat D).
  Proof.
    use tpair.
    - use tpair.
      + exact add_path_endpoints_ob_mor.
      + exact add_path_endpoints_id_comp.
    - intros Aa Bb f g θ. cbn. intros α δ ε γ.
      exact unit.
  Defined.

  Definition add_path_endpoints_ops : disp_prebicat_ops' add_path_endpoints_1_id_comp_cells.
  Proof.
    repeat split; exact tt.
  Qed.

  (* DFcell *)
  Definition add_path_endpoints_prebicat : disp_prebicat (total_prebicat D).
  Proof.
    use tpair.
    - exists add_path_endpoints_1_id_comp_cells.
      exact add_path_endpoints_ops.
    - abstract (repeat use tpair; red; intros; apply (proofirrelevance _ isapropunit)).
  Defined.

  Definition add_path_endpoints : prebicat := total_prebicat add_path_endpoints_prebicat.
End AddEndpoints.


From algebra Require Export upred.
From algebra Require Export upred_big_op.
Import uPred.

Module uPred_reflection. Section uPred_reflection.
  Context {M : cmraT}.

  Inductive expr :=
    | ETrue : expr
    | EVar : nat → expr
    | ESep : expr → expr → expr.
  Fixpoint eval (Σ : list (uPred M)) (e : expr) : uPred M :=
    match e with
    | ETrue => True
    | EVar n => from_option True%I (Σ !! n)
    | ESep e1 e2 => eval Σ e1 ★ eval Σ e2
    end.
  Fixpoint flatten (e : expr) : list nat :=
    match e with
    | ETrue => []
    | EVar n => [n]
    | ESep e1 e2 => flatten e1 ++ flatten e2
    end.

  Notation eval_list Σ l :=
    (uPred_big_sep ((λ n, from_option True%I (Σ !! n)) <$> l)).
  Lemma eval_flatten Σ e : eval Σ e ≡ eval_list Σ (flatten e).
  Proof.
    induction e as [| |e1 IH1 e2 IH2];
      rewrite /= ?right_id ?fmap_app ?big_sep_app ?IH1 ?IH2 //.
  Qed.
  Lemma flatten_entails Σ e1 e2 :
    flatten e2 `contains` flatten e1 → eval Σ e1 ⊑ eval Σ e2.
  Proof.
    intros. rewrite !eval_flatten. by apply big_sep_contains, fmap_contains.
  Qed.
  Lemma flatten_equiv Σ e1 e2 :
    flatten e2 ≡ₚ flatten e1 → eval Σ e1 ≡ eval Σ e2.
  Proof. intros He. by rewrite !eval_flatten He. Qed.

  Fixpoint prune (e : expr) : expr :=
    match e with
    | ETrue => ETrue
    | EVar n => EVar n
    | ESep e1 e2 =>
       match prune e1, prune e2 with
       | ETrue, e2' => e2'
       | e1', ETrue => e1'
       | e1', e2' => ESep e1' e2'
       end
    end.
  Lemma flatten_prune e : flatten (prune e) = flatten e.
  Proof.
    induction e as [| |e1 IH1 e2 IH2]; simplify_eq/=; auto.
    rewrite -IH1 -IH2. by repeat case_match; rewrite ?right_id_L.
  Qed.
  Lemma prune_correct Σ e : eval Σ (prune e) ≡ eval Σ e.
  Proof. by rewrite !eval_flatten flatten_prune. Qed.

  Fixpoint cancel_go (n : nat) (e : expr) : option expr :=
    match e with
    | ETrue => None
    | EVar n' => if decide (n = n') then Some ETrue else None
    | ESep e1 e2 =>
       match cancel_go n e1 with
       | Some e1' => Some (ESep e1' e2)
       | None => ESep e1 <$> cancel_go n e2
       end
    end.
  Definition cancel (ns : list nat) (e: expr) : option expr :=
    prune <$> fold_right (mbind ∘ cancel_go) (Some e) ns.
  Lemma flatten_cancel_go e e' n :
    cancel_go n e = Some e' → flatten e ≡ₚ n :: flatten e'.
  Proof.
    revert e'; induction e as [| |e1 IH1 e2 IH2]; intros;
      repeat (simplify_option_eq || case_match); auto.
    - by rewrite IH1 //.
    - by rewrite IH2 // Permutation_middle.
  Qed.
  Lemma flatten_cancel e e' ns :
    cancel ns e = Some e' → flatten e ≡ₚ ns ++ flatten e'.
  Proof.
    rewrite /cancel fmap_Some=> -[{e'}e' [He ->]]; rewrite flatten_prune.
    revert e' He; induction ns as [|n ns IH]=> e' He; simplify_option_eq; auto.
    rewrite Permutation_middle -flatten_cancel_go //; eauto.
  Qed.
  Lemma cancel_entails Σ e1 e2 e1' e2' ns :
    cancel ns e1 = Some e1' → cancel ns e2 = Some e2' →
    eval Σ e1' ⊑ eval Σ e2' → eval Σ e1 ⊑ eval Σ e2.
  Proof.
    intros ??. rewrite !eval_flatten.
    rewrite (flatten_cancel e1 e1' ns) // (flatten_cancel e2 e2' ns) //; csimpl.
    rewrite !fmap_app !big_sep_app. apply sep_mono_r.
  Qed.

  Fixpoint to_expr (l : list nat) : expr :=
    match l with
    | [] => ETrue
    | [n] => EVar n
    | n :: l => ESep (EVar n) (to_expr l)
    end.
  Arguments to_expr !_ / : simpl nomatch.
  Lemma eval_to_expr Σ l : eval Σ (to_expr l) ≡ eval_list Σ l.
  Proof.
    induction l as [|n1 [|n2 l] IH]; csimpl; rewrite ?right_id //.
    by rewrite IH.
  Qed.

  Lemma split_l Σ e ns e' :
    cancel ns e = Some e' → eval Σ e ≡ (eval Σ (to_expr ns) ★ eval Σ e')%I.
  Proof.
    intros He%flatten_cancel.
    by rewrite eval_flatten He fmap_app big_sep_app eval_to_expr eval_flatten.
  Qed.
  Lemma split_r Σ e ns e' :
    cancel ns e = Some e' → eval Σ e ≡ (eval Σ e' ★ eval Σ (to_expr ns))%I.
  Proof. intros. rewrite /= comm. by apply split_l. Qed.

  Class Quote (Σ1 Σ2 : list (uPred M)) (P : uPred M) (e : expr) := {}.
  Global Instance quote_True Σ : Quote Σ Σ True ETrue.
  Global Instance quote_var Σ1 Σ2 P i:
    rlist.QuoteLookup Σ1 Σ2 P i → Quote Σ1 Σ2 P (EVar i) | 1000.
  Global Instance quote_sep Σ1 Σ2 Σ3 P1 P2 e1 e2 :
    Quote Σ1 Σ2 P1 e1 → Quote Σ2 Σ3 P2 e2 → Quote Σ1 Σ3 (P1 ★ P2) (ESep e1 e2).

  Class QuoteArgs (Σ: list (uPred M)) (Ps: list (uPred M)) (ns: list nat) := {}.
  Global Instance quote_args_nil Σ : QuoteArgs Σ nil nil.
  Global Instance quote_args_cons Σ Ps P ns n :
    rlist.QuoteLookup Σ Σ P n →
    QuoteArgs Σ Ps ns → QuoteArgs Σ (P :: Ps) (n :: ns).
  End uPred_reflection.

  Ltac quote :=
    match goal with
    | |- ?P1 ⊑ ?P2 =>
      lazymatch type of (_ : Quote [] _ P1 _) with Quote _ ?Σ2 _ ?e1 =>
      lazymatch type of (_ : Quote Σ2 _ P2 _) with Quote _ ?Σ3 _ ?e2 =>
        change (eval Σ3 e1 ⊑ eval Σ3 e2) end end
    end.
  Ltac quote_l :=
    match goal with
    | |- ?P1 ⊑ ?P2 =>
      lazymatch type of (_ : Quote [] _ P1 _) with Quote _ ?Σ2 _ ?e1 =>
        change (eval Σ2 e1 ⊑ P2) end
    end.
End uPred_reflection.

Tactic Notation "solve_sep_entails" :=
  uPred_reflection.quote; apply uPred_reflection.flatten_entails;
  apply (bool_decide_unpack _); vm_compute; exact Logic.I.

Ltac close_uPreds Ps tac :=
  let M := match goal with |- @uPred_entails ?M _ _ => M end in
  let rec go Ps Qs :=
    lazymatch Ps with
    | [] => let Qs' := eval cbv [reverse rev_append] in (reverse Qs) in tac Qs'
    | ?P :: ?Ps => find_pat P ltac:(fun Q => go Ps (Q :: Qs))
    end in
  (* avoid evars in case Ps = @nil ?A *)
  try match Ps with [] => unify Ps (@nil (uPred M)) end;
  go Ps (@nil (uPred M)).

Tactic Notation "cancel" constr(Ps) :=
  uPred_reflection.quote;
  let Σ := match goal with |- uPred_reflection.eval ?Σ _ ⊑ _ => Σ end in
  let ns' := lazymatch type of (_ : uPred_reflection.QuoteArgs Σ Ps _) with
             | uPred_reflection.QuoteArgs _ _ ?ns' => ns'
             end in
  eapply uPred_reflection.cancel_entails with (ns:=ns');
    [cbv; reflexivity|cbv; reflexivity|simpl].

Tactic Notation "ecancel" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Qs => cancel Qs).

(** [to_front [P1, P2, ..]] rewrites in the premise of ⊑ such that
    the assumptions P1, P2, ... appear at the front, in that order. *)
Tactic Notation "to_front" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Ps =>
    uPred_reflection.quote_l;
    let Σ := match goal with |- uPred_reflection.eval ?Σ _ ⊑ _ => Σ end in
    let ns' := lazymatch type of (_ : uPred_reflection.QuoteArgs Σ Ps _) with
               | uPred_reflection.QuoteArgs _ _ ?ns' => ns'
               end in
    eapply entails_equiv_l;
      first (apply uPred_reflection.split_l with (ns:=ns'); cbv; reflexivity);
      simpl).

Tactic Notation "to_back" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Ps =>
    uPred_reflection.quote_l;
    let Σ := match goal with |- uPred_reflection.eval ?Σ _ ⊑ _ => Σ end in
    let ns' := lazymatch type of (_ : uPred_reflection.QuoteArgs Σ Ps _) with
               | uPred_reflection.QuoteArgs _ _ ?ns' => ns'
               end in
    eapply entails_equiv_l;
      first (apply uPred_reflection.split_r with (ns:=ns'); cbv; reflexivity);
      simpl).

(** [sep_split] is used to introduce a (★).
    Use [sep_split left: [P1, P2, ...]] to define which assertions will be
    taken to the left; the rest will be available on the right.
    [sep_split right: [P1, P2, ...]] works the other way around. *)
Tactic Notation "sep_split" "right:" open_constr(Ps) :=
  to_back Ps; apply sep_mono.
Tactic Notation "sep_split" "left:" open_constr(Ps) :=
  to_front Ps; apply sep_mono.

(** Assumes a goal of the shape P ⊑ ▷ Q. Alterantively, if Q
    is built of ★, ∧, ∨ with ▷ in all branches; that will work, too.
    Will turn this goal into P ⊑ Q and strip ▷ in P below ★, ∧, ∨. *)
Ltac strip_later :=
  let rec strip :=
    lazymatch goal with
    | |- (_ ★ _) ⊑ ▷ _  =>
      etrans; last (eapply equiv_entails_sym, later_sep);
      apply sep_mono; strip
    | |- (_ ∧ _) ⊑ ▷ _  =>
      etrans; last (eapply equiv_entails_sym, later_and);
      apply sep_mono; strip
    | |- (_ ∨ _) ⊑ ▷ _  =>
      etrans; last (eapply equiv_entails_sym, later_or);
      apply sep_mono; strip
    | |- ▷ _ ⊑ ▷ _ => apply later_mono; reflexivity
    | |- _ ⊑ ▷ _ => apply later_intro; reflexivity
    end
  in let rec shape_Q :=
    lazymatch goal with
    | |- _ ⊑ (_ ★ _) =>
      (* Force the later on the LHS to be top-level, matching laters
         below ★ on the RHS *)
      etrans; first (apply equiv_entails, later_sep; reflexivity);
      (* Match the arm recursively *)
      apply sep_mono; shape_Q
    | |- _ ⊑ (_ ∧ _) =>
      etrans; first (apply equiv_entails, later_and; reflexivity);
      apply sep_mono; shape_Q
    | |- _ ⊑ (_ ∨ _) =>
      etrans; first (apply equiv_entails, later_or; reflexivity);
      apply sep_mono; shape_Q
    | |- _ ⊑ ▷ _ => apply later_mono; reflexivity
    (* We fail if we don't find laters in all branches. *)
    end
  in intros_revert ltac:(etrans; [|shape_Q];
                         etrans; last eapply later_mono; first solve [ strip ]).

(** Transforms a goal of the form ∀ ..., ?0... → ?1 ⊑ ?2
    into True ⊑ ∀..., ■?0... → ?1 → ?2, applies tac, and
    the moves all the assumptions back. *)
(* TODO: this name may be a big too general *)
Ltac revert_all :=
  lazymatch goal with
  | |- ∀ _, _ =>
    let H := fresh in intro H; revert_all;
    (* TODO: Really, we should distinguish based on whether this is a
    dependent function type or not. Right now, we distinguish based
    on the sort of the argument, which is suboptimal. *)
    first [ apply (const_intro_impl _ _ _ H); clear H
          | revert H; apply forall_elim']
  | |- _ ⊑ _ => apply impl_entails
  end.

(** This starts on a goal of the form ∀ ..., ?0... → ?1 ⊑ ?2.
   It applies löb where all the Coq assumptions have been turned into logical
   assumptions, then moves all the Coq assumptions back out to the context,
   applies [tac] on the goal (now of the form _ ⊑ _), and then reverts the
   Coq assumption so that we end up with the same shape as where we started,
   but with an additional assumption ★-ed to the context *)
Ltac löb tac :=
  revert_all;
  (* Add a box *)
  etrans; last (eapply always_elim; reflexivity);
  (* We now have a goal for the form True ⊑ P, with the "original" conclusion
     being locked. *)
  apply löb_strong; etransitivity;
    first (apply equiv_entails, left_id, _; reflexivity);
  apply: always_intro;
  (* Now introduce again all the things that we reverted, and at the bottom,
     do the work *)
  let rec go :=
    lazymatch goal with
    | |- _ ⊑ (∀ _, _) =>
      apply forall_intro; let H := fresh in intro H; go; revert H
    | |- _ ⊑ (■ _ → _) =>
      apply impl_intro_l, const_elim_l; let H := fresh in intro H; go; revert H
    (* This is the "bottom" of the goal, where we see the impl introduced
       by uPred_revert_all as well as the ▷ from löb_strong and the □ we added. *)
    | |- ▷ □ ?R ⊑ (?L → _) => apply impl_intro_l;
      trans (L ★ ▷ □ R)%I;
        [eapply equiv_entails, always_and_sep_r, _; reflexivity | tac]
    end
  in go.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat ssrint ssralg seq choice fintype tuple.
(*Set Implicit Arguments.*)
(*Unset Strict Implicit.*)
Unset Printing Implicit Defensive.

Section Complex.

Variable complex : nat -> Type.

Definition rgrp (n : nat) := complex n -> int.

Definition radd {n : nat} (a b : rgrp n) : rgrp n :=
  fun x => GRing.add (a x) (b x).

Axiom extensional_rgrp : forall (n : nat) (g h : rgrp n), g =1 h <-> g = h.

Lemma raddA {n : nat} : associative (@radd n).
Proof.
  move => x y z.
  apply (proj1 (extensional_rgrp n (radd x (radd y z)) (radd (radd x y) z))).
  move => t.
  rewrite /radd.
  apply GRing.addrA.
Qed.

Lemma raddC {n : nat} : commutative (@radd n).
Proof.
  move => x y.
  apply (proj1 (extensional_rgrp n (radd x y) (radd y x))).
  move => t.
  rewrite /radd.
  apply GRing.addrC.
Qed.

Definition boundsRel (n : nat) := complex n -> complex n.+1 -> int.
Definition boundsRelNZf (n : nat) := complex n.+1 -> list (complex n).
Definition boundsRelNZb (n : nat) := complex n -> list (complex n.+1).

Variable bounds : forall n, boundsRel n.
Variable boundsNZf : forall n, boundsRelNZf n.
Variable boundsRestrf : forall (n : nat) (f : complex n) (t : complex n.+1),
                          bounds n f t <> 0 -> List.In f (boundsNZf n t).
Variable boundsNZb : forall n, boundsRelNZb n.
Variable boundsRestrb : forall (n : nat) (f : complex n.+1) (t : complex n),
                          bounds n t f <> 0 -> List.In f (boundsNZb n t).

Definition hdelta {n : nat} (g: rgrp n) : rgrp n.+1 :=
  fun y => foldr (fun (x y : int) => GRing.add x y) 0
           (map (fun z => intRing.mulz (bounds n z y) (g z)) (boundsNZf n y)).

Lemma hdelta_morf {n : nat} (a b : rgrp n): hdelta (radd a b) = radd (hdelta a) (hdelta b).
Proof.
  apply (proj1 (extensional_rgrp _ _ _)).
  move => t.
  rewrite /hdelta.
  rewrite [in RHS]/radd.
  move : (boundsNZf n t).
  elim => //=.
  rewrite !/radd.
  move => a0 l IH.
  rewrite GRing.addrA.
  rewrite [GRing.add _ (intRing.mulz (bounds n a0 t) (b a0))] GRing.addrC.
  rewrite [GRing.add (intRing.mulz (bounds n a0 t) (b a0)) _] GRing.addrA.
  rewrite - GRing.addrA.
  rewrite - IH.
  enough (intRing.mulz (bounds n a0 t) (GRing.add (a a0) (b a0)) =
          GRing.add (intRing.mulz (bounds n a0 t) (b a0))
                    (intRing.mulz (bounds n a0 t) (a a0))).
  - rewrite H. reflexivity.
  - rewrite !(intRing.mulzC (bounds n a0 t)).
    rewrite intRing.mulz_addl.
    rewrite GRing.addrC.
    reflexivity.
Qed.

Definition haxiom := forall (n : nat) (g: rgrp n) e, hdelta (hdelta g) e = 0.

Variable hconstraint : haxiom.

Definition Ker := forall (n: nat) (e: rgrp n) v, hdelta e v = 0.
Definition Im  := forall (n: nat) (e: rgrp n.+1), exists (x: rgrp n), hdelta x = e.

Record homoType (n: nat) := mkHomoType {
   grp: Type;
   grpOp: grp -> grp -> grp;
   grpOpA: associative grpOp;
   grpOpC: commutative grpOp;
   morf: (rgrp n.+1) -> grp;
   morfCorrect: forall (a b : rgrp n.+1), morf (radd a b) = grpOp (morf a) (morf b);
   morfSur: forall (x: grp), exists (x': rgrp n.+1), morf x' = x;
   factor: forall (x y : rgrp n),
             (morf \o hdelta) x = (morf \o hdelta) y -> hdelta x = hdelta y
}.


Require Import Undecidability.Synthetic.Definitions.

From Undecidability.PCP
  Require Import PCP Util.Facts PCPX_iff_dPCP.

Lemma PCPb_iff_dPCPb P : PCPb P <-> dPCPb P.
Proof. apply PCPX_iff_dPCP. Qed.

Lemma reductionLR : PCPb ⪯ dPCPb.
Proof.
  exists id. exact PCPb_iff_dPCPb.
Qed.

Lemma reductionRL : dPCPb ⪯ PCPb.
Proof.
  exists id. intro. now rewrite PCPb_iff_dPCPb.
Qed.


Require Import Coqlib.
Require Import Events.
Require Import Behaviors.
Require Import Maps.
Require Import Globalenvs.
Require Import Memtype.
Require Import Smallstep.
Require Import Integers.

Section Sum.

Context  {A: Type} (f: A -> Z).

Function sum (l: list A): Z :=
  match l with
    | nil => 0
    | a :: q => f a + sum q
  end.

Function sum_tailrec (accu: Z) (l: list A): Z :=
  match l with
    | nil => accu
    | a :: q => sum_tailrec (accu + f a) q
  end.

Lemma sum_app: forall l1 l2, sum (l1 ++ l2) = sum l1 + sum l2.
Proof.
  induction l1; simpl. reflexivity. intros. rewrite IHl1. omega.
Qed.

Lemma sum_tailrec_correct_aux:
  forall l2 l1,
    sum (l1 ++ l2) = sum_tailrec (sum l1) l2.
Proof.
  induction l2; simpl.
   intro. rewrite <- app_nil_end. reflexivity.
  intro. replace (l1 ++ a :: l2) with ((l1 ++ a :: nil) ++ l2). rewrite IHl2. rewrite sum_app. simpl. f_equal. omega.
  rewrite app_ass. reflexivity.
Qed.

Lemma sum_tailrec_correct:
  forall l,
    sum l = sum_tailrec 0 l.
Proof.
  intro. rewrite <- sum_tailrec_correct_aux with (l1 := nil). reflexivity.
Qed.

End Sum.

Section Event_needs_or_consumes.

Variable external_event_needs: event -> Z.

Function event_needs (e: event): Z :=
  match e with
    | Event_call f => 0
    | Event_return f => 0
    | _ => external_event_needs e
  end.

Definition trace_needs : forall (t: trace), Z := sum event_needs.

Variable stacksizes: PMap.t Z.

Function event_consumes (e: event): Z :=
  match e with
    | Event_call f => PMap.get f stacksizes
    | Event_return f => - PMap.get f stacksizes
    | _ => 0
  end.

Definition trace_consumes := sum event_consumes.

Definition event_needs_or_consumes (e: event): Z := event_needs e + event_consumes e.

Definition trace_needs_or_consumes := sum event_needs_or_consumes.

Lemma external_call_consumes: forall {F V: Type} (ge: Genv.t F V) ef args m t v m',
                                 external_call ef ge args m t v m' ->
                                 trace_consumes t = 0.
Proof with (subst; simpl; try reflexivity).
  destruct ef; simpl; inversion 1...
  inversion H0...
  inversion H0...
  inversion H1...
  inversion H1...
Qed.

Lemma external_call_needs: forall {F V: Type} (ge: Genv.t F V) ef args m t v m',
                                 external_call ef ge args m t v m' ->
                                 trace_needs_or_consumes t = trace_needs t.
Proof with (subst; simpl; unfold event_needs_or_consumes; simpl; try omega).
  destruct ef; simpl; inversion 1...
  inversion H0...
  inversion H0...
  inversion H1...
  inversion H1...
Qed.

Function trace_bound_and_consumes (needs_consumes: Z*Z) (t: trace): Z*Z :=
  match t with
    | nil => needs_consumes
    | e :: q =>
      match needs_consumes with
        | (needs, consumes) =>
            trace_bound_and_consumes (Z.max needs (consumes + event_needs_or_consumes e), consumes + event_consumes e) q
      end
  end.

Definition trace_bound (t: trace): Z :=
  fst (trace_bound_and_consumes (0, 0) t).

Lemma trace_bound_pos_aux:
  forall t needs consumes,
    needs <= fst (trace_bound_and_consumes (needs, consumes) t).
Proof.
  induction t; simpl.
   intros; omega.
  intros. eapply Z.le_trans. 2: eapply IHt. eapply Z.le_max_l.
Qed.

Corollary trace_bound_pos: forall t, 0 <= trace_bound t.
Proof.
  intros; eapply trace_bound_pos_aux.
Qed.

Lemma trace_bound_and_consumes_correct_aux:
  forall t needs consumes,
   snd (trace_bound_and_consumes (needs, consumes) t) = sum_tailrec event_consumes consumes t.
Proof.
  induction t; simpl.
  reflexivity.
 intros. rewrite IHt. reflexivity.
Qed.

Lemma trace_bound_and_consumes_correct:
  forall t,
    snd (trace_bound_and_consumes (0, 0) t) = trace_consumes t.
Proof.
  intros. unfold trace_consumes. rewrite sum_tailrec_correct. eauto using trace_bound_and_consumes_correct_aux.
Qed.

Lemma trace_bound_and_consumes_tailrec:
  forall l1 l2 accu,
    trace_bound_and_consumes accu (l1 ++ l2) =
    trace_bound_and_consumes (trace_bound_and_consumes accu l1) l2.
Proof.
  induction l1; simpl.
   reflexivity.
  intros.
  destruct accu.
  auto.
Qed.

Lemma trace_bound_single_event_needs_or_consumes':
  forall l e,
    trace_consumes l + event_needs_or_consumes e <= trace_bound (l ++ e :: nil).
Proof.
  intros. unfold trace_bound. rewrite trace_bound_and_consumes_tailrec. simpl.
  case_eq (trace_bound_and_consumes (0,0) l).
  intros.
  assert (z0 = snd (trace_bound_and_consumes (0,0) l)).
   rewrite H. reflexivity.
  clear H.
  subst.
  rewrite trace_bound_and_consumes_correct.
  simpl. apply Z.le_max_r.
Qed.

Lemma event_needs_or_consumes_eq: forall e,
                                    (event_needs_or_consumes e = event_needs e /\ event_consumes e = 0) \/ (event_needs_or_consumes e = event_consumes e /\ event_needs e = 0) .
Proof.
  unfold event_needs_or_consumes; destruct e; simpl; omega.
Qed.

Lemma trace_bound_ge_consumes_aux: forall t needs consumes,
                                 consumes <= needs ->
                                 snd (trace_bound_and_consumes (needs, consumes) t) <= fst (trace_bound_and_consumes (needs, consumes) t).
Proof.
  induction t; simpl.
   tauto.
  intros.
  eapply IHt.
  destruct (event_needs_or_consumes_eq a).
   destruct H0.
   rewrite H0.
   rewrite H1.
   eapply Z.le_trans.
   2: eapply Z.le_max_l.
   omega.
  destruct H0.
  rewrite H0.
  apply Z.le_max_r.
Qed.

Corollary trace_bound_ge_consumes: forall t,
                                     trace_consumes t <= trace_bound t.
Proof.
  intros. rewrite <- trace_bound_and_consumes_correct. eapply trace_bound_ge_consumes_aux. omega.
Qed.

Lemma trace_bound_single_event_needs_or_consumes:
  forall l', (length l' <= 1)%nat -> forall l,
    trace_consumes l + trace_needs_or_consumes l' <= trace_bound (l ++ l').
Proof.
  intros. destruct l'.
   rewrite <- app_nil_end. simpl. generalize (trace_bound_ge_consumes l). omega.
  destruct l'.
   simpl. generalize (trace_bound_single_event_needs_or_consumes' l e). omega.
  exfalso; simpl in *; omega.
Qed.

Theorem trace_bound_cons_right:
  forall l a,
    trace_bound (l ++ a :: nil) = Z.max (trace_bound l) (trace_consumes l + event_needs_or_consumes a).
Proof.
  unfold trace_bound. intros.
  rewrite trace_bound_and_consumes_tailrec.
  simpl.
  case_eq (trace_bound_and_consumes (0,0) l).
  intros.
  simpl.
  rewrite <- trace_bound_and_consumes_correct.
  rewrite H.
  reflexivity.
Qed.

Theorem trace_bound_app:
  forall l' l,
    trace_bound l <= trace_bound (l ++ l').
Proof.
  induction l' using rev_ind.
   intro. rewrite <- app_nil_end. omega.
  intro. eapply Z.le_trans. eauto. rewrite <- app_ass. rewrite trace_bound_cons_right. apply Z.le_max_l.
Qed.

Corollary trace_consumes_prefix_le_bound:
  forall l l',
    trace_consumes l <= trace_bound (l ++ l').
Proof.
  intros. eapply Z.le_trans. eapply trace_bound_ge_consumes. eapply trace_bound_app.
Qed.

Definition no_overflow bound (sem: semantics) :=
  forall beh : program_behavior,
       program_behaves sem beh ->
       not_wrong beh ->
       forall t : Events.trace,
         behavior_prefix t beh ->
         trace_bound t <= Integers.Int.unsigned bound.

End Event_needs_or_consumes.

(* Special case where external functions need zero space *)

Section NoExt.

Variable stacksizes: PMap.t Z.

Theorem trace_bound_no_external_cons_right:
  forall l a,
    trace_bound (fun _ => 0) stacksizes (l ++ a :: nil) = Z.max (trace_bound (fun _ => 0) stacksizes l) (trace_consumes stacksizes (l ++ a :: nil)).
Proof.
  intros.
  rewrite trace_bound_cons_right.
  f_equal.
  unfold trace_consumes.
  rewrite sum_app.
  f_equal.
  simpl.
  unfold event_needs_or_consumes.
  unfold event_needs.
  destruct a; omega.
Qed.

Theorem trace_bound_no_external_reached: forall l, exists l1, exists l2, l = l1 ++ l2 /\ trace_bound (fun _ => 0) stacksizes l = trace_consumes stacksizes l1.
Proof.
  induction l using rev_ind.
   exists nil. exists nil. split; reflexivity.
  rewrite trace_bound_no_external_cons_right.
  rewrite Zmax_spec.
  destruct (zlt (trace_consumes stacksizes (l ++ x :: nil)) (trace_bound (fun _ => 0) stacksizes l)).
   destruct IHl. destruct H. destruct H. subst. rewrite H0. exists x0. exists (x1 ++ x :: nil). split; auto. rewrite app_ass. reflexivity.
  exists (l ++ x :: nil). exists nil. split; auto. rewrite <- app_nil_end. reflexivity.
Qed.

Corollary trace_bound_no_external_principle:
  forall l z,
    (forall l1 l2, l = l1 ++ l2 -> trace_consumes stacksizes l1 <= z) <->
    trace_bound (fun _ => 0) stacksizes l <= z.
Proof.
  split.
   intros. generalize (trace_bound_no_external_reached l). destruct 1 as [l1 [l2 [? EQ]]]. rewrite EQ. subst. eauto.
  intros; subst. eapply Z.le_trans. eapply trace_consumes_prefix_le_bound. eassumption.
Qed.

Theorem no_overflow_single_events:
  forall
    sem (SINGLE: single_events sem)
    bound
    (NO_OVERFLOW: forall s, initial_state sem s ->
                            forall t s', Star sem s t s' -> trace_consumes stacksizes t <= Int.unsigned bound),
    no_overflow (fun _ => 0) stacksizes bound sem.
Proof.
  intros. red. inversion 1; subst; try contradiction.
  intros.
  exploit behaviors_single_events_prefix_inv.
   eassumption. eassumption. eassumption.
  destruct 1 as [? [? [? [? ?]]]]; subst.
  apply trace_bound_no_external_principle.
  intros; subst.
  exploit star_single_events_app_inv.
   eassumption. eassumption. reflexivity.
  destruct 1 as [? [? ?]].
  eauto.
Qed.

End NoExt.


Require Import Coq.Classes.Morphisms.

Require Import Crypto.Spec.CompleteEdwardsCurve Crypto.CompleteEdwardsCurve.CompleteEdwardsCurveTheorems.

Require Import Crypto.Algebra Crypto.Algebra.
Require Import Crypto.Util.Notations Crypto.Util.GlobalSettings.
Require Export Crypto.Util.FixCoqMistakes Crypto.Util.Tactics.

Module Extended.
  Section ExtendedCoordinates.
    Context {F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {field:@field F Feq Fzero Fone Fopp Fadd Fsub Fmul Finv Fdiv}
            {char_ge_3 : @Ring.char_ge F Feq Fzero Fone Fopp Fadd Fsub Fmul (BinNat.N.succ_pos BinNat.N.two)}
            {Feq_dec:DecidableRel Feq}.
    Local Infix "=" := Feq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
    Local Notation "0" := Fzero.  Local Notation "1" := Fone.
    Local Infix "+" := Fadd. Local Infix "*" := Fmul.
    Local Infix "-" := Fsub. Local Infix "/" := Fdiv.
    Local Notation "x ^ 2" := (x*x).

    Context {a d: F}
            {nonzero_a : a <> 0}
            {square_a : exists sqrt_a, sqrt_a^2 = a}
            {nonsquare_d : forall x, x^2 <> d}.
    Local Notation Epoint := (@E.point F Feq Fone Fadd Fmul a d).

    Local Notation onCurve x y := (a*x^2 + y^2 = 1 + d*x^2*y^2) (only parsing).
    (** [Extended.point] represents a point on an elliptic curve using extended projective
     * Edwards coordinates 1 (see <https://eprint.iacr.org/2008/522.pdf>). *)
    Definition point := { P | let '(X,Y,Z,T) := P in
                              a * X^2*Z^2 + Y^2*Z^2 = (Z^2)^2 + d * X^2 * Y^2
                              /\ X * Y = Z * T
                              /\ Z <> 0 }.
    Definition coordinates (P:point) : F*F*F*F := proj1_sig P.
    Definition eq (P1 P2:point) :=
        let '(X1, Y1, Z1, _) := coordinates P1 in
        let '(X2, Y2, Z2, _) := coordinates P2 in
        Z2*X1 = Z1*X2 /\ Z2*Y1 = Z1*Y2.

    Ltac t_step :=
      match goal with
      | |- Proper _ _ => intro
      | _ => progress intros
      | _ => progress destruct_head' prod
      | _ => progress destruct_head' @E.point
      | _ => progress destruct_head' point
      | _ => progress destruct_head' and
      | _ => progress cbv [eq CompleteEdwardsCurve.E.eq E.eq E.zero E.add E.opp fst snd coordinates E.coordinates proj1_sig] in *
      | |- _ /\ _ => split | |- _ <-> _ => split
      end.
    Ltac t := repeat t_step; Field.fsatz.

    Global Instance Equivalence_eq : Equivalence eq.
    Proof. split; repeat intro; t. Qed.
    Global Instance DecidableRel_eq : Decidable.DecidableRel eq.
    Proof. intros P Q; destruct P as [ [ [ [ ] ? ] ? ] ?], Q as [ [ [ [ ] ? ] ? ] ? ]; exact _. Defined.

    Program Definition from_twisted (P:Epoint) : point :=
      let xy := E.coordinates P in (fst xy, snd xy, 1, fst xy * snd xy).
    Next Obligation. t. Qed.
    Global Instance Proper_from_twisted : Proper (E.eq==>eq) from_twisted.
    Proof. cbv [from_twisted]; t. Qed.

    Program Definition to_twisted (P:point) : Epoint :=
      let XYZT := coordinates P in let T := snd XYZT in
      let XYZ  := fst XYZT in      let Z := snd XYZ in
      let XY   := fst XYZ in       let Y := snd XY in
      let X    := fst XY in
      let iZ := Finv Z in ((X*iZ), (Y*iZ)).
    Next Obligation. t. Qed.
    Global Instance Proper_to_twisted : Proper (eq==>E.eq) to_twisted.
    Proof. cbv [to_twisted]; t. Qed.

    Lemma to_twisted_from_twisted P : E.eq (to_twisted (from_twisted P)) P.
    Proof. cbv [to_twisted from_twisted]; t. Qed.
    Lemma from_twisted_to_twisted P : eq (from_twisted (to_twisted P)) P.
    Proof. cbv [to_twisted from_twisted]; t. Qed.

    Program Definition zero : point := (0, 1, 1, 0).
    Next Obligation. t. Qed.

    Program Definition opp P : point :=
      match coordinates P return F*F*F*F with (X,Y,Z,T) => (Fopp X, Y, Z, Fopp T) end.
    Next Obligation. t. Qed.

    Section TwistMinusOne.
      Context {a_eq_minus1:a = Fopp 1} {twice_d} {k_eq_2d:twice_d = d+d}.
      Program Definition m1add
              (P1 P2:point) : point :=
        match coordinates P1, coordinates P2 return F*F*F*F with
          (X1, Y1, Z1, T1), (X2, Y2, Z2, T2) =>
          let A := (Y1-X1)*(Y2-X2) in
          let B := (Y1+X1)*(Y2+X2) in
          let C := T1*twice_d*T2 in
          let D := Z1*(Z2+Z2) in
          let E := B-A in
          let F := D-C in
          let G := D+C in
          let H := B+A in
          let X3 := E*F in
          let Y3 := G*H in
          let T3 := E*H in
          let Z3 := F*G in
          (X3, Y3, Z3, T3)
        end.
      Next Obligation. pose proof (E.denominator_nonzero _ nonzero_a square_a _ nonsquare_d _ _ (proj2_sig (to_twisted P1))  _ _  (proj2_sig (to_twisted P2))); t. Qed.

      Program Definition _group_proof nonzero_a' square_a' nonsquare_d' : group /\ _ /\ _ :=
                 @Group.group_from_redundant_representation
                   _ _ _ _ _
                   ((E.edwards_curve_abelian_group(a:=a)(d:=d)(nonzero_a:=nonzero_a')(square_a:=square_a')
                                                  (nonsquare_d:=nonsquare_d')).(abelian_group_group))
                   _
                   eq
                   m1add
                   zero
                   opp
                   from_twisted
                   to_twisted
                   to_twisted_from_twisted
                   _ _ _ _.
      Next Obligation. cbv [to_twisted]. t. Qed.
      Next Obligation.
        match goal with
        | |- context[E.add ?P ?Q] =>
          unique pose proof (E.denominator_nonzero _ nonzero_a square_a _ nonsquare_d _ _  (proj2_sig P)  _ _  (proj2_sig Q))
        end. cbv [to_twisted m1add]. t. Qed.
      Next Obligation. cbv [to_twisted opp]. t. Qed.
      Next Obligation. cbv [to_twisted zero]. t. Qed.
      Global Instance group x y z
        : group := proj1 (_group_proof x y z).
      Global Instance homomorphism_from_twisted x y z :
        Monoid.is_homomorphism := proj1 (proj2 (_group_proof x y z)).
      Global Instance homomorphism_to_twisted x y z :
        Monoid.is_homomorphism := proj2 (proj2 (_group_proof x y z)).
    End TwistMinusOne.
  End ExtendedCoordinates.
End Extended.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=   Cons : natural -> lst -> lst | Nil : lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rotate (rotate_arg0 : natural) (rotate_arg1 : lst) : lst
           := match rotate_arg0, rotate_arg1 with
              | Zero, x => x
              | Succ n, Nil => Nil
              | Succ n, Cons y x => rotate n (append x (Cons y Nil))
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.

Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - simpl. rewrite IHx. reflexivity.
   - reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rotate (len x) (append x y)) (append y x).
Proof.
   induction x.
   - intros. simpl. lfind. Admitted.


Require Import List.
Import ListNotations.

Require Import Net.
Require Import StructTact.StructTactics.

Class TraceRelation `{State : Type} `{Event : Type} (step : step_relation State Event) :=
  {
    init : State;
    T : (list Event) -> Prop;
    T_dec : forall l, {T l} + {~ T l};
    R : State -> Prop;
    R_monotonic : forall s s' tr o, refl_trans_1n_trace step init s tr ->
                               step s s' o ->
                               R s ->
                               R s';
    T_false_init : ~ T [];
    T_implies_R : forall tr s s' o,
                    refl_trans_1n_trace step init s tr ->
                    ~ T tr ->
                    step s s' o ->
                    T (tr ++ o) ->
                    R s'
  }.

Section TraceRelations.
  Context `{TR : TraceRelation}.

  Theorem trace_relations_work :
    forall s tr,
      refl_trans_1n_trace step init s tr ->
      T tr -> R s.
  Proof using.
    intros.
    find_copy_apply_lem_hyp refl_trans_1n_n1_trace.
    remember init as s'.
    induction H1.
    - intros; exfalso; eauto using T_false_init.
    - subst. destruct (T_dec cs); intuition eauto using R_monotonic, refl_trans_n1_1n_trace, T_implies_R.
  Qed.
End TraceRelations.


From iris.algebra Require Export
  view.

From caml5 Require Import
  prelude.
From caml5.algebra Require Export
  base.

Section cmra.
  Context {A B} (rel : view_rel A B).
  Implicit Types a : A.
  Implicit Types b : B.

  Lemma view_auth_frag_dfrac_op dq1 a1 b1 dq2 a2 b2 :
    ●V{dq1} a1 ⋅ ◯V b1 ≡@{view rel} ●V{dq2} a2 ⋅ ◯V b2 ↔
    dq1 = dq2 ∧ a1 ≡ a2 ∧ b1 ≡ b2.
  Proof.
    split.
    - intros (Hauth & Hfrag).
      rewrite /= !left_id in Hfrag. rewrite /= !right_id in Hauth.
      apply (inj Some) in Hauth as (-> & ->%(inj to_agree)). done.
    - intros (-> & -> & ->). done.
  Qed.
  Lemma view_auth_frag_op a1 b1 a2 b2 :
    ●V a1 ⋅ ◯V b1 ≡@{view rel} ●V a2 ⋅ ◯V b2 ↔
    a1 ≡ a2 ∧ b1 ≡ b2.
  Proof.
    rewrite view_auth_frag_dfrac_op. naive_solver.
  Qed.
End cmra.


Require Import Sail2_values.
Require List.
Import List.ListNotations.

(*** Bit vector operations *)

Section Bitvectors.
Context {a b c} `{Bitvector a} `{Bitvector b} `{Bitvector c}.

(*val concat_bv : forall 'a 'b 'c. Bitvector 'a, Bitvector 'b, Bitvector 'c => 'a -> 'b -> 'c*)
Definition concat_bv (l : a) (r : b) : list bitU := bits_of l ++ bits_of r.

(*val cons_bv : forall 'a 'b 'c. Bitvector 'a, Bitvector 'b => bitU -> 'a -> 'b*)
Definition cons_bv b' (v : a) : list bitU := b' :: bits_of v.

Definition cast_unit_bv b : list bitU := [b].
Definition bv_of_bit len b : list bitU := extz_bits len [b].

(*Definition most_significant v := match bits_of v with
  | cons b _ => b
  | _ => failwith "most_significant applied to empty vector"
  end.

Definition get_max_representable_in sign (n : integer) : integer :=
  if (n = 64) then match sign with | true -> max_64 | false -> max_64u end
  else if (n=32) then match sign with | true -> max_32 | false -> max_32u end
  else if (n=8) then max_8
  else if (n=5) then max_5
  else match sign with | true -> integerPow 2 ((natFromInteger n) -1)
                       | false -> integerPow 2 (natFromInteger n)
       end

Definition get_min_representable_in _ (n : integer) : integer :=
  if n = 64 then min_64
  else if n = 32 then min_32
  else if n = 8 then min_8
  else if n = 5 then min_5
  else 0 - (integerPow 2 (natFromInteger n))

val arith_op_bv_int : forall 'a 'b. Bitvector 'a =>
  (integer -> integer -> integer) -> bool -> 'a -> integer -> 'a*)
Definition arith_op_bv_int {a} `{Bitvector a} (op : Z -> Z -> Z) (sign : bool) (l : a) (r : Z) : a :=
  let r' := of_int (length l) r in
  arith_op_bv op sign l r'.

(*val arith_op_int_bv : forall 'a 'b. Bitvector 'a =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a*)
Definition arith_op_int_bv {a} `{Bitvector a} (op : Z -> Z -> Z) (sign : bool) (l : Z) (r : a) : a :=
  let l' := of_int (length r) l in
  arith_op_bv op sign l' r.
(*
Definition add_bv_int := arith_op_bv_int Zplus false 1.
Definition sadd_bv_int := arith_op_bv_int Zplus true 1.
Definition sub_bv_int := arith_op_bv_int Zminus false 1.
Definition mult_bv_int := arith_op_bv_int Zmult false 2.
Definition smult_bv_int := arith_op_bv_int Zmult true 2.

(*val arith_op_int_bv : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> integer -> 'a -> 'b
Definition arith_op_int_bv op sign size l r :=
  let r' = int_of_bv sign r in
  let n = op l r' in
  of_int (size * length r) n

Definition add_int_bv = arith_op_int_bv integerAdd false 1
Definition sadd_int_bv = arith_op_int_bv integerAdd true 1
Definition sub_int_bv = arith_op_int_bv integerMinus false 1
Definition mult_int_bv = arith_op_int_bv integerMult false 2
Definition smult_int_bv = arith_op_int_bv integerMult true 2

Definition arith_op_bv_bit op sign (size : integer) l r :=
  let l' = int_of_bv sign l in
  let n = op l' (match r with | B1 -> (1 : integer) | _ -> 0 end) in
  of_int (size * length l) n

Definition add_bv_bit := arith_op_bv_bit integerAdd false 1
Definition sadd_bv_bit := arith_op_bv_bit integerAdd true 1
Definition sub_bv_bit := arith_op_bv_bit integerMinus true 1

val arith_op_overflow_bv : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a -> ('b * bitU * bitU)
Definition arith_op_overflow_bv op sign size l r :=
  let len := length l in
  let act_size := len * size in
  let (l_sign,r_sign) := (int_of_bv sign l,int_of_bv sign r) in
  let (l_unsign,r_unsign) := (int_of_bv false l,int_of_bv false r) in
  let n := op l_sign r_sign in
  let n_unsign := op l_unsign r_unsign in
  let correct_size := of_int act_size n in
  let one_more_size_u := bits_of_int (act_size + 1) n_unsign in
  let overflow :=
    if n <= get_max_representable_in sign len &&
         n >= get_min_representable_in sign len
    then B0 else B1 in
  let c_out := most_significant one_more_size_u in
  (correct_size,overflow,c_out)

Definition add_overflow_bv := arith_op_overflow_bv integerAdd false 1
Definition add_overflow_bv_signed := arith_op_overflow_bv integerAdd true 1
Definition sub_overflow_bv := arith_op_overflow_bv integerMinus false 1
Definition sub_overflow_bv_signed := arith_op_overflow_bv integerMinus true 1
Definition mult_overflow_bv := arith_op_overflow_bv integerMult false 2
Definition mult_overflow_bv_signed := arith_op_overflow_bv integerMult true 2

val arith_op_overflow_bv_bit : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> bitU -> ('b * bitU * bitU)
Definition arith_op_overflow_bv_bit op sign size l r_bit :=
  let act_size := length l * size in
  let l' := int_of_bv sign l in
  let l_u := int_of_bv false l in
  let (n,nu,changed) := match r_bit with
    | B1 -> (op l' 1, op l_u 1, true)
    | B0 -> (l',l_u,false)
    | BU -> failwith "arith_op_overflow_bv_bit applied to undefined bit"
    end in
  let correct_size := of_int act_size n in
  let one_larger := bits_of_int (act_size + 1) nu in
  let overflow :=
    if changed
    then
      if n <= get_max_representable_in sign act_size && n >= get_min_representable_in sign act_size
      then B0 else B1
    else B0 in
  (correct_size,overflow,most_significant one_larger)

Definition add_overflow_bv_bit := arith_op_overflow_bv_bit integerAdd false 1
Definition add_overflow_bv_bit_signed := arith_op_overflow_bv_bit integerAdd true 1
Definition sub_overflow_bv_bit := arith_op_overflow_bv_bit integerMinus false 1
Definition sub_overflow_bv_bit_signed := arith_op_overflow_bv_bit integerMinus true 1

type shift := LL_shift | RR_shift | RR_shift_arith | LL_rot | RR_rot

val shift_op_bv : forall 'a. Bitvector 'a => shift -> 'a -> integer -> 'a
Definition shift_op_bv op v n :=
  match op with
  | LL_shift ->
     of_bits (get_bits true v n (length v - 1) ++ repeat [B0] n)
  | RR_shift ->
     of_bits (repeat [B0] n ++ get_bits true v 0 (length v - n - 1))
  | RR_shift_arith ->
     of_bits (repeat [most_significant v] n ++ get_bits true v 0 (length v - n - 1))
  | LL_rot ->
     of_bits (get_bits true v n (length v - 1) ++ get_bits true v 0 (n - 1))
  | RR_rot ->
     of_bits (get_bits false v 0 (n - 1) ++ get_bits false v n (length v - 1))
  end

Definition shiftl_bv := shift_op_bv LL_shift (*"<<"*)
Definition shiftr_bv := shift_op_bv RR_shift (*">>"*)
Definition arith_shiftr_bv := shift_op_bv RR_shift_arith
Definition rotl_bv := shift_op_bv LL_rot (*"<<<"*)
Definition rotr_bv := shift_op_bv LL_rot (*">>>"*)

Definition shiftl_mword w n := Machine_word.shiftLeft w (natFromInteger n)
Definition shiftr_mword w n := Machine_word.shiftRight w (natFromInteger n)
Definition rotl_mword w n := Machine_word.rotateLeft (natFromInteger n) w
Definition rotr_mword w n := Machine_word.rotateRight (natFromInteger n) w

Definition rec arith_op_no0 (op : integer -> integer -> integer) l r :=
  if r = 0
  then Nothing
  else Just (op l r)

val arith_op_bv_no0 : forall 'a 'b. Bitvector 'a, Bitvector 'b =>
  (integer -> integer -> integer) -> bool -> integer -> 'a -> 'a -> 'b
Definition arith_op_bv_no0 op sign size l r :=
  let act_size := length l * size in
  let (l',r') := (int_of_bv sign l,int_of_bv sign r) in
  let n := arith_op_no0 op l' r' in
  let (representable,n') :=
    match n with
    | Just n' ->
      (n' <= get_max_representable_in sign act_size &&
         n' >= get_min_representable_in sign act_size, n')
    | _ -> (false,0)
    end in
  if representable then (of_int act_size n') else (of_bits (repeat [BU] act_size))

Definition mod_bv := arith_op_bv_no0 hardware_mod false 1
Definition quot_bv := arith_op_bv_no0 hardware_quot false 1
Definition quot_bv_signed := arith_op_bv_no0 hardware_quot true 1

Definition mod_mword := Machine_word.modulo
Definition quot_mword := Machine_word.unsignedDivide
Definition quot_mword_signed := Machine_word.signedDivide

Definition arith_op_bv_int_no0 op sign size l r :=
  arith_op_bv_no0 op sign size l (of_int (length l) r)

Definition quot_bv_int := arith_op_bv_int_no0 hardware_quot false 1
Definition mod_bv_int := arith_op_bv_int_no0 hardware_mod false 1
*)
Definition replicate_bits_bv {a b} `{Bitvector a} `{Bitvector b} (v : a) count : b := of_bits (repeat (bits_of v) count).
Import List.
Import ListNotations.
Definition duplicate_bit_bv {a} `{Bitvector a} bit len : a := replicate_bits_bv [bit] len.

(*val eq_bv : forall 'a. Bitvector 'a => 'a -> 'a -> bool*)
Definition eq_bv {A} `{Bitvector A} (l : A) r := (unsigned l =? unsigned r).

(*val neq_bv : forall 'a. Bitvector 'a => 'a -> 'a -> bool*)
Definition neq_bv (l : a) (r :a) : bool := (negb (unsigned l =? unsigned r)).
(*
val ucmp_bv : forall 'a. Bitvector 'a => (integer -> integer -> bool) -> 'a -> 'a -> bool
Definition ucmp_bv cmp l r := cmp (unsigned l) (unsigned r)

val scmp_bv : forall 'a. Bitvector 'a => (integer -> integer -> bool) -> 'a -> 'a -> bool
Definition scmp_bv cmp l r := cmp (signed l) (signed r)

Definition ult_bv := ucmp_bv (<)
Definition slt_bv := scmp_bv (<)
Definition ugt_bv := ucmp_bv (>)
Definition sgt_bv := scmp_bv (>)
Definition ulteq_bv := ucmp_bv (<=)
Definition slteq_bv := scmp_bv (<=)
Definition ugteq_bv := ucmp_bv (>=)
Definition sgteq_bv := scmp_bv (>=)
*)

(*val get_slice_int_bv : forall 'a. Bitvector 'a => integer -> integer -> integer -> 'a*)*)
Definition get_slice_int_bv {a} `{Bitvector a} len n lo : a :=
  let hi := lo + len - 1 in
  let bs := bools_of_int (hi + 1) n in
  of_bools (subrange_list false bs hi lo).

(*val set_slice_int_bv : forall 'a. Bitvector 'a => integer -> integer -> integer -> 'a -> integer
Definition set_slice_int_bv {a} `{Bitvector a} len n lo (v : a) :=
  let hi := lo + len - 1 in
  let bs := bits_of_int (hi + 1) n in
  maybe_failwith (signed_of_bits (update_subrange_list false bs hi lo (bits_of v))).*)

End Bitvectors.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

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

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      - rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem drop_assoc : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  + rewrite 2 drop_Cons_assoc. reflexivity.
  + rewrite 3 drop_Nil. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (w : natural) (z : lst), eq (drop w (drop x (drop y z))) (drop y (drop x (drop w z))).
Proof.
  intros.
  lfind. Admitted.


(* coq-robot (c) 2017 AIST and INRIA. License: LGPL-2.1-or-later. *)
From mathcomp Require Import all_ssreflect ssralg ssrint ssrnum rat poly.
From mathcomp Require Import closed_field polyrcf matrix mxalgebra mxpoly zmodp.
From mathcomp Require Import realalg complex fingroup perm.
From mathcomp Require Import interval reals trigo.
Require Import ssr_ext euclidean skew vec_angle rot frame rigid screw.
From mathcomp.analysis Require Import reals forms.
Require Import extra_trigo.

(******************************************************************************)
(*                        SCARA Robot Manipulator                             *)
(*                                                                            *)
(* This file addresses the forward kinematics problem for the SCARA robot     *)
(* manipulator in two ways: (1) it first provides the DH parameters,          *)
(* (2) using screw motions.                                                   *)
(*                                                                            *)
(* B10,B21,B32,B43 == relative positions of the consecutive frames of the     *)
(*                    SCARA robot manipulator using DH parameters             *)
(*     t1,t2,t3,t4 == twists of the SCARA robot manipulator                   *)
(*              g0 == position of the end-effector using twists               *)
(*               g == orientation of the end-effector using twists            *)
(*                                                                            *)
(******************************************************************************)

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

Import GRing.Theory.
Import Num.Theory.

Local Open Scope ring_scope.

Section scara.

Variable R : realType.
Let vector := 'rV[R]_3.

Variable theta1 : R.
Variable a1 : R.
Variable theta2 : R.
Variable a2 : R.
Variable d3 : R.
Variable theta4 : R.
Variable d4 : R.

Definition scara_rot := Rz (theta1 + theta2 + theta4).

Definition scara_trans := row3
  (a2 * cos (theta2 + theta1) + a1 * cos theta1)
  (a2 * sin (theta2 + theta1) + a1 * sin theta1)
  (d4 + d3).

(* [spong] p. 81, eqn. 3.49 *)
Section hom_scara.

Definition A10 := hom (Rz theta1) (row3 (a1 * cos theta1) (a1 * sin theta1) 0).
Definition A21 := hom (Rz theta2) (row3 (a2 * cos theta2) (a2 * sin theta2) 0).
Definition A32 := hTz d3.
Definition A43 := hom (Rz theta4) (row3 0 0 d4).

Lemma hom_SCARA_forward : A43 * A32 * A21 * A10 = hom scara_rot scara_trans.
Proof.
rewrite /A43 /A32.
rewrite homM mulr1 mulmx1 row3D. Simp.r.
rewrite /A21.
rewrite homM RzM mulmx_row3_col3 !scale0r !add0r e2row !row3Z row3D. Simp.r.
rewrite homM RzM addrC (addrC _ theta2) addrA; congr hom.
rewrite mulmx_row3_col3 e2row !row3Z !row3D. Simp.r.
by rewrite -!mulrA -mulrBr -cosD -mulrDr (addrC (_ * sin theta1)) -sinD.
Qed.

End hom_scara.

Section dh_scara.

Definition B10 := hTx a1 * hRz theta1.
Definition B21 := hTx a2 * hRz theta2.
Definition B32 := hTz d3.
Definition B43 := hTz d4 * hRz theta4.

Lemma dh_SCARA_forward : B43 * B32 * B21 * B10 = hom scara_rot scara_trans.
Proof.
rewrite -hom_SCARA_forward /B10 hTxRz -/A10 /B21 hTxRz -/A21.
by rewrite /B32 -/A32 /B43 /A43 hTzRz.
Qed.

End dh_scara.

(* [murray] example 3.1, p.87 *)
Section screw_scara.

(* initial configuration *)
Definition g0 := hom 1 (row3 (a1 + a2) 0 d4).

Definition w1 : vector := 'e_2%:R.
Definition w2 : vector := 'e_2%:R.
Definition v3 : vector := 'e_2%:R.
Definition w4 : vector := 'e_2%:R.

(* axis points *)
Definition q1 : vector := 0.
Definition q2 : vector := row3 a1 0 0.
Definition q4 : vector := row3 (a1 + a2) 0 0.

Definition t1 := rjoint_twist w1 q1.
Definition t2 := rjoint_twist w2 q2.
Definition t3 := pjoint_twist v3.
Definition t4 := rjoint_twist w4 q4.

Definition g := g0 * `e$(theta4, t4) *
  `e$(d3, t3) * `e$(theta2, t2) * `e$(theta1, t1).

Lemma S1 : `e$(theta1, t1) = hRz theta1.
Proof.
rewrite /t1 /rjoint_twist linearNl /= linear0r oppr0 etwist_Rz; last first.
  by rewrite -norm_eq0 normeE oner_eq0.
by rewrite -Rz_eskew.
Qed.

(* TODO: generalize *)
Lemma point_axis_twist (d : R) :
  \pt( axis \T((- 'e_2%:R *v row3 d 0 0), 'e_2%:R) ) = row3 d 0 0.
Proof.
rewrite {1}/axis ang_tcoorE (negbTE (norm1_neq0 (normeE _ _))) /=.
rewrite normeE expr1n invr1 scale1r lin_tcoorE linearNl linearNr /=.
rewrite double_crossmul dotmulvv normeE expr1n scale1r /w2 /q2 e2row.
rewrite dotmulE sum3E !mxE /=. by Simp.r.
Qed.

Lemma S2_helper th d :
  `e$(th, \T(- w2 *v row3 d 0 0, w2)) =
  hom (Rz th) (row3 (d * (1 - cos th)) (- d * sin th) 0).
Proof.
rewrite etwistE (negbTE (norm1_neq0 (normeE _ _))).
rewrite pitch_perp ?normeE // mulr0 scale0r add0r.
rewrite point_axis_twist -Rz_eskew; congr hom.
rewrite mulmxBr mulmx1 mulmx_row3_col3 !scale0r !addr0 row3Z row3N row3D.
Simp.r.
by rewrite mulrBr mulr1.
Qed.

Lemma S2 : `e$(theta2, t2) =
  hom (Rz theta2) (row3 (a1 * (1 - cos theta2)) (- a1 * sin theta2) 0).
Proof. by rewrite /t2 S2_helper. Qed.

Lemma S3 : `e$(d3, t3) = hTz d3.
Proof.
rewrite etwistE eqxx eskew_v0.
rewrite /hTz /v3 e2row row3Z. by Simp.r.
Qed.

Lemma S4 : `e$(theta4, t4) = hom (Rz theta4)
  (row3 ((a1 + a2) * (1 - cos theta4)) (- (a1 + a2) * sin theta4) 0).
Proof. by rewrite /t4 /q4 S2_helper. Qed.

Lemma screw_SCARA_forward : g = hom scara_rot scara_trans.
Proof.
rewrite /g /g0 S1 S2 S3 S4 homM mul1r.
rewrite mulmx_row3_col3 scale0r addr0 e2row 2!row3Z 2!row3D. Simp.r.
rewrite mulrBr mulr1 addrCA subrr addr0 subrr.
rewrite homM mulr1 mulmx1 row3D. Simp.r.
rewrite homM RzM mulmx_row3_col3 e2row !row3Z !row3D. Simp.r.
rewrite (addrC _ (a1 * (1 - cos theta2))) mulrBr mulr1 mulrDl !addrA subrK.
rewrite mulrDl addrAC subrr add0r.
rewrite homM RzM mulmx_row3_col3 e2row !row3Z !row3D. Simp.r.
rewrite addrC (addrC theta4) addrA; congr hom.
rewrite /scara_trans; congr row3.
- by rewrite mulrDl -addrA -!mulrA -mulrBr -cosD addrC.
- by rewrite mulrDl -addrA -!mulrA -mulrDr (addrC (cos theta2 * _)) -sinD addrC.
Qed.

End screw_scara.

End scara.


(* Copyright (c) 2008-2009, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* Dependent list types presented in Chapter 9 *)

Require Import Arith List Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section ilist.
  Variable A : Type.

  Inductive ilist : nat -> Type :=
  | INil : ilist O
  | ICons : forall n, A -> ilist n -> ilist (S n).

  Definition hd n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S _ => A
                                end with
      | INil => tt
      | ICons _ x _ => x
    end.
  Definition tl n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S n => ilist n
                                end with
      | INil => tt
      | ICons _ _ ls' => ls'
    end.

  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | INil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | ICons _ x ls' => fun idx =>
        match idx in fin n' return (fin (pred n') -> A) -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun get_ls' => get_ls' idx'
        end (get ls')
    end.

  Section everywhere.
    Variable x : A.

    Fixpoint everywhere (n : nat) : ilist n :=
      match n with
        | O => INil
        | S n' => ICons x (everywhere n')
      end.
  End everywhere.

  Section singleton.
    Variables x default : A.

    Fixpoint singleton (n m : nat) : ilist n :=
      match n with
        | O => INil
        | S n' =>
          match m with
            | O => ICons x (everywhere default n')
            | S m' => ICons default (singleton n' m')
          end
      end.
  End singleton.

  Section map2.
    Variable f : A -> A -> A.

    Fixpoint map2 n (il1 : ilist n) : ilist n -> ilist n :=
      match il1 in ilist n return ilist n -> ilist n with
        | INil => fun _ => INil
        | ICons _ x il1' => fun il2 => ICons (f x (hd il2)) (map2 il1' (tl il2))
      end.
  End map2.

  Section fold.
    Variable B : Type.
    Variable f : A -> B -> B.
    Variable i : B.

    Fixpoint foldr n (il : ilist n) : B :=
      match il with
        | INil => i
        | ICons _ x il' => f x (foldr il')
      end.
  End fold.
End ilist.

Implicit Arguments INil [A].
Implicit Arguments First [n].

Section imap.
  Variables A B : Type.
  Variable f : A -> B.

  Fixpoint imap n (il : ilist A n) : ilist B n :=
    match il with
      | INil => INil
      | ICons _ x il' => ICons (f x) (imap il')
    end.
End imap.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  Definition hhd ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | x :: _ => B x
                                end with
      | HNil => tt
      | HCons _ _ v _ => v
    end.

  Definition htl ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | _ :: ls' => hlist ls'
                                end with
      | HNil => tt
      | HCons _ _ _ hl' => hl'
    end.

  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
      | HNil => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => B elm
                                          | _ :: _ => unit
                                        end) with
          | HFirst _ => tt
          | HNext _ _ _ => tt
        end
      | HCons _ _ x mls' => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => Empty_set
                                          | x' :: ls'' =>
                                            B x' -> (member ls'' -> B elm) -> B elm
                                        end) with
          | HFirst _ => fun x _ => x
          | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
        end x (hget mls')
    end.

  Fixpoint happ (ls1 : list A) (hl1 : hlist ls1) : forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) :=
    match hl1 in hlist ls1 return forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) with
      | HNil => fun _ hl2 => hl2
      | HCons _ _ x hl1' => fun _ hl2 => HCons x (happ hl1' hl2)
    end.

  Variable f : forall x, B x.

  Fixpoint hmake (ls : list A) : hlist ls :=
    match ls with
      | nil => HNil
      | x :: ls' => HCons (f x) (hmake ls')
    end.

  Theorem hget_hmake : forall ls (m : member ls),
    hget (hmake ls) m = f elm.
    induction ls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hlist.

Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].
Implicit Arguments hmake [A B].

Implicit Arguments HFirst [A elm ls].
Implicit Arguments HNext [A elm x ls].

Infix ":::" := HCons (right associativity, at level 60).
Infix "+++" := happ (right associativity, at level 60).

Section hmap.
  Variable A : Type.
  Variables B1 B2 : A -> Type.

  Variable f : forall x, B1 x -> B2 x.

  Fixpoint hmap (ls : list A) (hl : hlist B1 ls) : hlist B2 ls :=
    match hl with
      | HNil => HNil
      | HCons _ _ x hl' => f x ::: hmap hl'
    end.

  Theorem hmap_happ : forall ls2 (h2 : hlist B1 ls2) ls1 (h1 : hlist B1 ls1),
    hmap h1 +++ hmap h2 = hmap (h1 +++ h2).
    induction h1; crush.
  Qed.

  Theorem hget_hmap : forall elm ls (hls : hlist B1 ls) (m : member elm ls),
    hget (hmap hls) m = f (hget hls m).
    induction hls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hmap.

Implicit Arguments hmap [A B1 B2 ls].


(* ------------------ Descriptions--------------------------------------------------

 In this file we define the concept of covering a graph with Stable Sets and Cliqs. We
 also describe the relationship of chromatic number of an undirected graph and the min
 size of stable set cover for the graph. Most of these new definitions are given using
 functions which are originally defined in the file SetCover.v. Furthermore, we also
 prove various lemmas specifying the relationship between a graph and its complement.

We connect these  properties with boolean functions using the following reflection lemmas.

 Predicate                  Boolean function       Joining Lemma
 Stable_cover C G           stable_cover C G       stable_coverP
 Cliq_cover C G             cliq_cover C G         cliq_coverP

 (Stable_cover C G) states that C is a collection of stable sets that spans the whole graph G.
 (Cliq_cover C G) states that C is a collection of cliques that spans the whole graph G.

 We also prove following important results relating the size of smallest stable color and
 chromatic number for a given graph G:

 Lemma color_to_cover (G:UG) (f: A-> nat): Coloring_of G f ->
                                         (exists C, Stable_cover C G /\ |C| = |clrs_of f G|).

Lemma cover_to_color (G:UG) (C: list (list A)):
 Stable_cover C G -> (exists f, Coloring_of G f /\ |clrs_of f G| <= |C|).

Lemma nice_intro1 (G: UG)(n:nat): cliq_num G n ->
                                  (exists C, Stable_cover C G /\ | C | = n) -> Nice G.

---------------------------------------------------------------------------------------*)

Require Export MoreUG.
Require Export SetCover.

Set Implicit Arguments.

Section GraphCover.

  Context { A: ordType }.

  (*--------- Stable set cover for a graph G -------------------------------*)

  Definition stable_cover (C: list (list A))(G: UG):=
    set_cover C G && forallb (fun I => (stable G I && isOrd I)) C.

  Definition Stable_cover (C: list (list A))(G: UG):=
    Set_cover C G /\ (forall I, In I C -> (Stable G I /\ IsOrd I)).

  Lemma stable_coverP (C: list (list A))(G: UG): reflect (Stable_cover C G)(stable_cover C G).
  Proof. { apply reflect_intro. split;unfold stable_cover;unfold Stable_cover.
           { intros h1. split_. apply /set_coverP. apply h1. apply /forallbP.
             intros x h2. apply /andP;split. apply /stableP. apply h1. auto.
             apply /isOrdP. apply h1;auto. }
           { intros h1. move /andP in h1. destruct h1 as [h1 h1a].
             split. apply /set_coverP. auto.
             intros I h2. move /forallbP in h1a.
             specialize (h1a I h2) as h3. move /andP in h3.
             split. apply /stableP;apply h3. apply /isOrdP;apply h3. } } Qed.

  Lemma Stable_cover_elim (C: list (list A))(G: UG)(I: list A):
    Stable_cover C G -> In I C -> Stable_in G I.
  Proof. { unfold Stable_cover; unfold Stable_in. intros h1 h2.
           destruct h1 as [h1a h1b]. specialize (h1b I h2) as h3.
           destruct h3 as [h3a h3b]. split. eauto. split;auto. } Qed.

     Hint Resolve Stable_cover_elim: core.

  (*---------  Cliq cover for a graph G -------------------------------*)

  Definition cliq_cover (C: list (list A))(G: UG):=
    set_cover C G && forallb (fun I => (cliq G I && isOrd I)) C.

  Definition Cliq_cover (C: list (list A))(G: UG):=
    Set_cover C G /\ (forall I, In I C -> (Cliq G I /\ IsOrd I)).

  Lemma cliq_coverP (C: list (list A))(G: UG): reflect (Cliq_cover C G)(cliq_cover C G).
  Proof. { apply reflect_intro. split;unfold cliq_cover;unfold Cliq_cover.
           { intros h1. split_. apply /set_coverP. apply h1. apply /forallbP.
             intros x h2. apply /andP;split. apply /cliqP. apply h1. auto.
             apply /isOrdP. apply h1;auto. }
           { intros h1. move /andP in h1. destruct h1 as [h1 h1a].
             split. apply /set_coverP. auto.
             intros I h2. move /forallbP in h1a.
             specialize (h1a I h2) as h3. move /andP in h3.
             split. apply /cliqP;apply h3. apply /isOrdP;apply h3. } } Qed.

  Lemma Cliq_cover_elim (C: list (list A))(G: UG)(K: list A):
    Cliq_cover C G -> In K C -> Cliq_in G K.
  Proof. { unfold Cliq_cover; unfold Cliq_in. intros h1 h2.
           destruct h1 as [h1a h1b]. specialize (h1b K h2) as h3.
           destruct h3 as [h3a h3b]. split. eauto. split;auto. } Qed.

  Hint Resolve Cliq_cover_elim: core.

  (*----------- Smallest Stable_cover Vs Chromatic Number --------------- *)

  Lemma color_to_cover (G:UG) (f: A-> nat): Coloring_of G f ->
                                         (exists C, Stable_cover C G /\ |C| = |clrs_of f G|).
  Proof. { intro h1.
           (*--all colors used in G is stored in cls ------*)
           set (cl:= clrs_of f G).
           set (F:= fun c => (filter (fun v => f v == c) G)).
           set (C:= map F cl).
           exists C. split.
           { (*---Stable_cover C G----*)
             unfold Stable_cover.
             split.
             { (*----Set_cover C G----*)
               unfold Set_cover. apply set_equal. all: auto.
               split.
               { (*--  G [<=] union_over C ---*)
                 intros x h2. set (Cx := F (f x)).
                 assert (Hx: In x Cx).
                 { unfold Cx. unfold F.
                   apply filter_In. split;auto. }
                 assert (HCx: In Cx C).
                 { unfold C. unfold Cx. cut (In (f x) cl).
                   auto. unfold cl. unfold clrs_of. auto. }
                 eapply union_over_intro. apply Hx. auto. }
               { (*--- union_over C [<=] G ----*)
                 intros x h2.
                 apply union_over_elim in h2 as h3.
                 destruct h3 as [Cx h3]. destruct h3 as [h3a h3b].
                 unfold C in h3a.
                 assert (h4: exists c, In c cl /\ Cx = F c). auto.
                 destruct h4 as [c h4]. destruct h4 as [h4a h4].
                 subst Cx. unfold F in h3b. eapply filter_elim1. apply h3b. }  }
             { (*-- forall I : list A, In I C -> Stable G I /\ IsOrd I---*)
               intros I h2.
               split.
               { (*-Stable G I-*)
                 unfold Stable. intros x y hx hy.
                 assert (h3: exists c, In c cl /\ I = F c).
                 { unfold C in h2. auto. }
                 destruct h3 as [c h3]. destruct h3 as [h3a h3b].
                 subst I. unfold F in hx, hy.
                 assert (hfx: f x == c).
                 { apply filter_elim2 in hx as h4. auto. }
                 assert (hfy: f y == c).
                 { apply filter_elim2 in hy as h4. auto. }
                 assert (Hx: In x G).
                 {  apply filter_elim1 in hx as h4; auto. }
                 assert (Hy: In y G).
                 {  apply filter_elim1 in hy as h4; auto. }
                 switch. intro h4.
                 absurd (f x = f y). auto. move /eqP in hfx. move /eqP in hfy.
                 omega. }
               { (*-IsOrd I -*)
                 assert (h3: exists c, In c cl /\ I = F c).
                 { unfold C in h2. auto. }
                 destruct h3 as [c h3]. destruct h3 as [h3a h3b].
                 subst I. unfold F. cut (IsOrd G). auto. auto. }  }  }
           { (*-- (| C |) = (| cl |)--*)
             unfold C. symmetry. auto.  } } Qed.

  Lemma cover_to_color (G:UG) (C: list (list A)): Stable_cover C G ->
                                                  ( exists f, Coloring_of G f /\ |clrs_of f G| <= |C|).
  Proof. { intro h1.
           set (f:= fun x => idc x C).
           set (cl:= clrs_of f G).
           set (Nc:= map (fun c => idx c C) C).
           exists f. split.
           { (*-- Coloring_of G f ---*)
             unfold Coloring_of.
             destruct h1 as [h1 h1a]. unfold Set_cover in h1.
             intros x y hx hy hxy h2.
             assert (h3: exists c, In c C /\ In x c /\ In y c).
             { apply idc_eq_same_set. rewrite <- h1. auto.
               unfold f in h2. auto. }
             destruct h3 as [c h3].
             assert (h4: Stable G c).
             { apply h1a. apply h3. }
             unfold Stable in h4.
             absurd ( edg G x y). switch. apply h4;apply h3. auto. }

           { (*--  (| clrs_of f G |) <= (| C |) --*)
             assert (h2: clrs_of f G [<=] Nc).
             { unfold clrs_of. intros n h3.
               assert (h4: exists x, In x G /\ n = f x). auto.
               destruct h4 as [x h4]. destruct h4 as [h4a h4].
               unfold f in h4.
               assert (h5:  exists c, In c C /\  In x c /\ idc x C = idx c C).
               { apply idc_from_idx. unfold Stable_cover in h1.
                 destruct h1 as [h1 h1a]. unfold Set_cover in h1.
                 rewrite <- h1;auto. }
               destruct h5 as [c h5]. subst n.
               replace (idc x C) with (idx c C).
               unfold Nc. set (f1:= (fun c0 : list_eqType => idx c0 C)).
               replace (idx c C) with (f1 c).
               cut (In c C). auto. apply h5. unfold f1;simpl;auto.
               symmetry;apply h5. }
             assert (h3: NoDup (clrs_of f G )).
             { unfold clrs_of. auto. }
             assert (h4: |C| = |Nc|).
             { unfold Nc. auto. }
             rewrite h4. auto. } } Qed.

  Lemma disj_cover_to_color (G:UG) (C: list (list A)):
    Stable_cover C G -> NoDup C-> (forall I1 I2, In I1 C-> In I2 C-> I1 <> I2 -> (I1 [i] I2) = nil )->
    (forall I, In I C -> I <> nil)->  ( exists f, Coloring_of G f /\ |clrs_of f G| = |C|).

  Proof. { intros h1 H0 H1 H2.
           set (f:= fun x => idc x C).
           set (cl:= clrs_of f G).
           set (Nc:= map (fun c => idx c C) C).
           exists f. split.
           { (*-- Coloring_of G f ---*)
             unfold Coloring_of.
             destruct h1 as [h1 h1a]. unfold Set_cover in h1.
             intros x y hx hy hxy h2.
             assert (h3: exists c, In c C /\ In x c /\ In y c).
             { apply idc_eq_same_set. rewrite <- h1. auto.
               unfold f in h2. auto. }
             destruct h3 as [c h3].
             assert (h4: Stable G c).
             { apply h1a. apply h3. }
             unfold Stable in h4.
             absurd ( edg G x y). switch. apply h4;apply h3. auto. }

           assert (hle: (| clrs_of f G |) <= (| C |)).
           { (*--  (| clrs_of f G |) <= (| C |) --*)
             assert (h2: clrs_of f G [<=] Nc).
             { unfold clrs_of. intros n h3.
               assert (h4: exists x, In x G /\ n = f x). auto.
               destruct h4 as [x h4]. destruct h4 as [h4a h4].
               unfold f in h4.
               assert (h5:  exists c, In c C /\  In x c /\ idc x C = idx c C).
               { apply idc_from_idx. unfold Stable_cover in h1.
                 destruct h1 as [h1 h1a]. unfold Set_cover in h1.
                 rewrite <- h1;auto. }
               destruct h5 as [c h5]. subst n.
               replace (idc x C) with (idx c C).
               unfold Nc. set (f1:= (fun c0 : list_eqType => idx c0 C)).
               replace (idx c C) with (f1 c).
               cut (In c C). auto. apply h5. unfold f1;simpl;auto.
               symmetry;apply h5. }
             assert (h3: NoDup (clrs_of f G )).
             { unfold clrs_of. auto. }
             assert (h4: |C| = |Nc|).
             { unfold Nc. auto. }
             rewrite h4. auto. }

           assert (hge: (| C |) <= (| clrs_of f G |)).
            { (*--   (| C |) <= (| clrs_of f G |) --*)
             assert (h2: Nc [<=] clrs_of f G).
             { intros n h2.
               assert (h2a: exists I, In I C /\ n = (idx I C)).
               { unfold Nc in h2. auto. }
               destruct h2a as [I h2a]. destruct h2a as [h2a h2b].
               assert (H2a: I <> nil).
               { auto. }
               assert (H2b: exists a, In a I). auto.
               destruct H2b as [a H2b].
               assert (H2c: In a (union_over C)). eauto.
               eapply idc_from_idx in H2c as H2d.
               destruct H2d as [I' H2d]. destruct H2d as [H2d H2e].
               destruct H2e as [H2e H2f].
               assert (h3: I = I').
               { assert (hI: I = I' \/ I <> I'). eauto.
                 destruct hI as [hI |hI]. auto.
                 assert (h3: I [i] I' = nil).
                 { apply H1. all: auto. }
                 assert (h4: In a (I [i] I')). auto.
                 rewrite h3 in h4. simpl in h4. auto. }
               subst I'. subst n.  unfold clrs_of.
               rewrite <- H2f. replace (idc a C) with (f a).
               cut (In a G).  auto. unfold Stable_cover in h1.
               destruct h1 as [h1 h1a]. unfold Set_cover in h1.
               rewrite h1. auto. unfold f. auto.  }
             assert (h3: NoDup Nc).
             { unfold Nc. apply NoDup_map. auto. eauto.
               unfold one_one_on. intros x y. apply diff_index. }
             assert (h4: |C| = |Nc|).
             { unfold Nc. auto. }
             rewrite h4. auto. }     omega.   } Qed.

 Lemma nice_intro1 (G: UG)(n:nat): cliq_num G n -> (exists C, Stable_cover C G /\ | C | = n) -> Nice G.
  Proof. { intros h1 h2. eapply nice_intro with (n0:=n).
           auto. destruct h2 as [C h2]. destruct h2 as [h2a h2b].
           specialize (cover_to_color  h2a) as h3.
           destruct h3 as [f h3]. destruct h3 as [h3a h3b].
           exists f. split. auto. rewrite h2b in h3b.
           cut ((| clrs_of f G |) >= n). intros. omega. auto. } Qed.

End GraphCover.

Hint Resolve Stable_cover_elim: core.
Hint Resolve Cliq_cover_elim: core.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Set Contextual Implicit.
Implicit Arguments Nil.
Unset Contextual Implicit.
Implicit Arguments Cons.

Set Implicit Arguments.
Fixpoint length (a:Type)(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.
Unset Implicit Arguments.

Axiom Length_nonnegative : forall (a:Type), forall (l:(list a)),
  (0%Z <= (length l))%Z.

Axiom Length_nil : forall (a:Type), forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil:(list a))).

Set Implicit Arguments.
Fixpoint infix_plpl (a:Type)(l1:(list a)) (l2:(list a)) {struct l1}: (list
  a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.
Unset Implicit Arguments.

Axiom Append_assoc : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall (a:Type), forall (l:(list a)), ((infix_plpl l
  (Nil:(list a))) = l).

Axiom Append_length : forall (a:Type), forall (l1:(list a)) (l2:(list a)),
  ((length (infix_plpl l1 l2)) = ((length l1) + (length l2))%Z).

Set Implicit Arguments.
Fixpoint mem (a:Type)(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.
Unset Implicit Arguments.

Axiom mem_append : forall (a:Type), forall (x:a) (l1:(list a)) (l2:(list a)),
  (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x l2)).

Axiom mem_decomp : forall (a:Type), forall (x:a) (l:(list a)), (mem x l) ->
  exists l1:(list a), exists l2:(list a), (l = (infix_plpl l1 (Cons x l2))).

Set Implicit Arguments.
Fixpoint reverse (a:Type)(l:(list a)) {struct l}: (list a) :=
  match l with
  | Nil => (Nil:(list a))
  | (Cons x r) => (infix_plpl (reverse r) (Cons x (Nil:(list a))))
  end.
Unset Implicit Arguments.

Axiom reverse_append : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (x:a), ((infix_plpl (reverse (Cons x l1)) l2) = (infix_plpl (reverse l1)
  (Cons x l2))).

Axiom reverse_reverse : forall (a:Type), forall (l:(list a)),
  ((reverse (reverse l)) = l).

Axiom Reverse_length : forall (a:Type), forall (l:(list a)),
  ((length (reverse l)) = (length l)).

Inductive option (a:Type) :=
  | None : option a
  | Some : a -> option a.
Set Contextual Implicit.
Implicit Arguments None.
Unset Contextual Implicit.
Implicit Arguments Some.

Parameter nth: forall (a:Type), Z -> (list a) -> (option a).

Implicit Arguments nth.

Axiom nth_def : forall (a:Type), forall (n:Z) (l:(list a)),
  match l with
  | Nil => ((nth n l) = (None:(option a)))
  | (Cons x r) => ((n = 0%Z) -> ((nth n l) = (Some x))) /\ ((~ (n = 0%Z)) ->
      ((nth n l) = (nth (n - 1%Z)%Z r)))
  end.

Parameter m: Z.

Axiom m_positive : (0%Z <  m)%Z.

Parameter n: Z.

Axiom n_nonnegative : (0%Z <= n)%Z.

Inductive shuffle{a:Type}  : (list a) -> (list a) -> (list a) -> Prop :=
  | Shuffle_nil_left : forall (l:(list a)), (shuffle l (Nil:(list a)) l)
  | Shuffle_nil_right : forall (l:(list a)), (shuffle (Nil:(list a)) l l)
  | Shuffle_cons_left : forall (x:a) (a1:(list a)) (b:(list a)) (c:(list a)),
      (shuffle a1 b c) -> (shuffle (Cons x a1) b (Cons x c))
  | Shuffle_cons_right : forall (x:a) (a1:(list a)) (b:(list a)) (c:(list
      a)), (shuffle a1 b c) -> (shuffle a1 (Cons x b) (Cons x c)).
Implicit Arguments shuffle.

Axiom shuffle_nil_nil_nil : forall (a:Type), (shuffle (Nil:(list a))
  (Nil:(list a)) (Nil:(list a))).

(* YOU MAY EDIT THE CONTEXT BELOW *)
Hint Constructors shuffle.
(* DO NOT EDIT BELOW *)

Theorem shuffle_sym : forall (a:Type), forall (a1:(list a)) (b:(list a))
  (c:(list a)), (shuffle a1 b c) -> (shuffle b a1 c).
(* YOU MAY EDIT THE PROOF BELOW *)
induction 1; intuition.
Qed.
(* DO NOT EDIT BELOW *)


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.euclidean_tactics.
Require Import ProofCheckingEuclid.lemma_NCdistinct.
Require Import ProofCheckingEuclid.lemma_betweennotequal.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_ABD_BCD.
Require Import ProofCheckingEuclid.lemma_collinearorder.
Require Import ProofCheckingEuclid.lemma_inequalitysymmetric.
Require Import ProofCheckingEuclid.lemma_onray_impliescollinear.
Require Import ProofCheckingEuclid.lemma_onray_orderofpoints_any.
Require Import ProofCheckingEuclid.lemma_onray_strict.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_ACD_BCD.
Require Import ProofCheckingEuclid.lemma_orderofpoints_ABC_BCD_ACD.
Require Import ProofCheckingEuclid.lemma_otherside_betweenness_PABC_RPQ_QABC.
Require Import ProofCheckingEuclid.lemma_otherside_betweenness_PABC_RQP_QABC.
Require Import ProofCheckingEuclid.lemma_s_n_col_ncol.
Require Import ProofCheckingEuclid.lemma_s_ncol_n_col.
Require Import ProofCheckingEuclid.lemma_s_os.
Require Import ProofCheckingEuclid.lemma_s_ss.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_sameside_onray :
	forall A B C E F G,
	SS E F A C ->
	Col A B C ->
	OnRay B F G ->
	SS E G A C.
Proof.
	intros A B C E F G.
	intros SS_E_F_AC.
	intros Col_A_B_C.
	intros OnRay_BF_G.

	assert (SS_E_F_AC2 := SS_E_F_AC).
	destruct SS_E_F_AC2 as (Q & U & V & Col_A_C_U & Col_A_C_V & BetS_E_U_Q & BetS_F_V_Q & nCol_A_C_E & nCol_A_C_F).

	pose proof (lemma_collinearorder _ _ _ Col_A_C_V) as (Col_C_A_V  & _ &  Col_V_A_C & _ & Col_V_C_A).

	pose proof (lemma_betweennotequal _ _ _ BetS_F_V_Q) as (_ & _ & neq_F_Q).
	pose proof (lemma_inequalitysymmetric _ _ neq_F_Q) as neq_Q_F.

	assert (Col F V Q) as Col_F_V_Q by (unfold Col; one_of_disjunct BetS_F_V_Q).
	pose proof (lemma_collinearorder _ _ _ Col_F_V_Q) as (_ & _ & Col_Q_F_V & _ & _).

	pose proof (lemma_NCdistinct _ _ _ nCol_A_C_E) as (neq_A_C & _ & _ & neq_C_A & _ & _).

	pose proof (lemma_s_ncol_n_col _ _ _ nCol_A_C_F) as n_Col_A_C_F.

	pose proof (lemma_collinearorder _ _ _ Col_A_B_C) as (_ & Col_B_C_A & Col_C_A_B & Col_A_C_B & _).

	pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_C_A_B Col_C_A_V neq_C_A) as Col_A_B_V.
	pose proof (lemma_collinearorder _ _ _ Col_A_B_V) as (_ & Col_B_V_A & _ & _ & _).

	pose proof (lemma_onray_strict _ _ _ OnRay_BF_G) as neq_B_G.
	pose proof (lemma_inequalitysymmetric _ _ neq_B_G) as neq_G_B.

	pose proof (lemma_onray_impliescollinear _ _ _ OnRay_BF_G) as Col_B_F_G.
	pose proof (lemma_collinearorder _ _ _ Col_B_F_G) as (_ & _ & Col_G_B_F & _ & _).

	pose proof (lemma_s_os _ _ _ _ _ BetS_F_V_Q Col_A_C_V nCol_A_C_F) as OS_F_AC_Q.

	assert (eq F G \/ neq F G) as [eq_F_G|neq_F_G] by (apply Classical_Prop.classic).
	{
		(* case eq_F_G *)

		assert (SS E G A C) as SS_E_G_AC by (rewrite <- eq_F_G; exact SS_E_F_AC).
		exact SS_E_G_AC.
	}
	(* case neq_F_G *)

	assert (eq B V \/ neq B V) as [eq_B_V|neq_B_V] by (apply Classical_Prop.classic).
	{
		(* case eq_B_V *)

		assert (BetS F B Q) as BetS_F_B_Q by (rewrite eq_B_V; exact BetS_F_V_Q).

		assert (BetS G B Q) as BetS_G_B_Q.
		pose proof (lemma_onray_orderofpoints_any _ _ _ OnRay_BF_G) as [BetS_B_G_F|[eq_F_G|BetS_B_F_G]].
		{
			(* case BetS_B_G_F *)
			pose proof (axiom_betweennesssymmetry _ _ _ BetS_B_G_F) as BetS_F_G_B.
			pose proof (lemma_orderofpoints_ABC_ACD_BCD _ _ _ _ BetS_F_G_B BetS_F_B_Q) as BetS_B_G_Q.
			exact BetS_B_G_Q.
		}
		{
			(* case eq_F_G *)
			assert (BetS G B Q) as BetS_G_B_Q by (rewrite <- eq_F_G; exact BetS_F_B_Q).
			exact BetS_G_B_Q.
		}
		{
			(* case BetS_B_F_G *)
			pose proof (axiom_betweennesssymmetry _ _ _ BetS_B_F_G) as BetS_G_F_B.
			pose proof (lemma_orderofpoints_ABC_BCD_ACD _ _ _ _ BetS_G_F_B BetS_F_B_Q) as BetS_G_B_Q.
			exact BetS_G_B_Q.
		}
		(* asserted BetS_G_B_Q *)

		assert (~ Col A C G) as n_Col_A_C_G.
		{
			intros Col_A_C_G.

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_C_G Col_A_C_B neq_A_C) as Col_C_G_B.
			pose proof (lemma_collinearorder _ _ _ Col_C_G_B) as (_ & Col_G_B_C & _ & _ & _).
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_B_C Col_G_B_F neq_G_B) as Col_B_C_F.

			assert (~ neq B C) as eq_B_C.
			{
				intros neq_B_C.

				pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_C_F Col_B_C_A neq_B_C) as Col_C_F_A.
				pose proof (lemma_collinearorder _ _ _ Col_C_F_A) as (_ & _ & Col_A_C_F & _ & _).

				contradict Col_A_C_F.
				exact n_Col_A_C_F.
			}
			apply Classical_Prop.NNPP in eq_B_C.

			assert (Col A B G) as Col_A_B_G by (rewrite eq_B_C; exact Col_A_C_G).
			pose proof (lemma_collinearorder _ _ _ Col_A_B_G) as (_ & _ & _ & _ & Col_G_B_A).
			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_B_A Col_G_B_F neq_G_B) as Col_B_A_F.
			pose proof (lemma_collinearorder _ _ _ Col_B_A_F) as (Col_A_B_F & _ & _ & _ & _).

			assert (Col A C F) as Col_A_C_F by (rewrite <- eq_B_C; exact Col_A_B_F).

			contradict Col_A_C_F.
			exact n_Col_A_C_F.
		}
		pose proof (lemma_s_n_col_ncol _ _ _ n_Col_A_C_G) as nCol_A_C_G.

		pose proof (lemma_s_os _ _ _ _ _ BetS_G_B_Q Col_A_C_B nCol_A_C_G) as OS_G_AC_Q.

		destruct OS_G_AC_Q as (H & BetS_G_H_Q & Col_A_C_H & _).
		pose proof (lemma_s_ss _ _ _ _ _ _ _ Col_A_C_U Col_A_C_H BetS_E_U_Q BetS_G_H_Q nCol_A_C_E nCol_A_C_G) as SS_E_G_AC.
		exact SS_E_G_AC.
	}
	(* case neq_B_V *)

	assert (~ Col Q F B) as n_Col_Q_F_B.
	{
		intros Col_Q_F_B.
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_Q_F_B Col_Q_F_V neq_Q_F) as Col_F_B_V.
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_A_C_B Col_A_C_V neq_A_C) as Col_C_B_V.
		pose proof (lemma_collinearorder _ _ _ Col_F_B_V) as (_ & Col_B_V_F & _ & _ & _).
		pose proof (lemma_collinearorder _ _ _ Col_C_B_V) as (_ & Col_B_V_C & _ & _ & _).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_V_F Col_B_V_C neq_B_V) as Col_V_F_C.
		pose proof (lemma_collinearorder _ _ _ Col_V_F_C) as (_ & _ & _ & Col_V_C_F & _).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_B_V_F Col_B_V_A neq_B_V) as Col_V_F_A.
		pose proof (lemma_collinearorder _ _ _ Col_V_F_A) as (_ & _ & _ & Col_V_A_F & _).

		assert (~ neq V C) as eq_V_C.
		{
			intros neq_V_C.

			pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_V_C_F Col_V_C_A neq_V_C) as Col_C_F_A.
			pose proof (lemma_collinearorder _ _ _ Col_C_F_A) as (_ & _ & Col_A_C_F & _ & _).

			contradict Col_A_C_F.
			exact n_Col_A_C_F.
		}
		apply Classical_Prop.NNPP in eq_V_C.

		assert (neq A V) as neq_A_V by (rewrite eq_V_C; exact neq_A_C).
		pose proof (lemma_inequalitysymmetric _ _ neq_A_V) as neq_V_A.

		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_V_A_F Col_V_A_C neq_V_A) as Col_A_F_C.
		pose proof (lemma_collinearorder _ _ _ Col_A_F_C) as (_ & _ & _ & Col_A_C_F & _).

		contradict Col_A_C_F.
		exact n_Col_A_C_F.

	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_Q_F_B) as nCol_Q_F_B.

	pose proof (lemma_onray_orderofpoints_any _ _ _ OnRay_BF_G) as [BetS_B_G_F|[eq_F_G|BetS_B_F_G]].
	{
		(* case BetS_B_G_F *)
		pose proof (lemma_otherside_betweenness_PABC_RQP_QABC _ _ _ _ _ _ OS_F_AC_Q BetS_B_G_F nCol_Q_F_B Col_A_C_B) as OS_G_AC_Q.

		destruct OS_G_AC_Q as (H & BetS_G_H_Q & Col_A_C_H & nCol_A_C_G).
		pose proof (lemma_s_ss _ _ _ _ _ _ _ Col_A_C_U Col_A_C_H BetS_E_U_Q BetS_G_H_Q nCol_A_C_E nCol_A_C_G) as SS_E_G_AC.
		exact SS_E_G_AC.
	}
	{
		(* case eq_F_G *)
		contradict eq_F_G.
		exact neq_F_G.
	}
	(* case BetS_B_F_G *)

	assert (~ Col B G Q) as n_Col_B_G_Q.
	{
		intros Col_B_G_Q.

		pose proof (lemma_collinearorder _ _ _ Col_B_G_Q) as (Col_G_B_Q & _ & _ & _ & _).
		pose proof (lemma_collinear_ABC_ABD_BCD _ _ _ _ Col_G_B_F Col_G_B_Q neq_G_B) as Col_B_F_Q.
		pose proof (lemma_collinearorder _ _ _ Col_B_F_Q) as (_ & _ & _ & _ & Col_Q_F_B).

		contradict Col_Q_F_B.
		exact n_Col_Q_F_B.
	}
	pose proof (lemma_s_n_col_ncol _ _ _ n_Col_B_G_Q) as nCol_B_G_Q.

	pose proof (lemma_otherside_betweenness_PABC_RPQ_QABC _ _ _ _ _ _ OS_F_AC_Q BetS_B_F_G nCol_B_G_Q Col_A_C_B) as OS_G_AC_Q.

	destruct OS_G_AC_Q as (H & BetS_G_H_Q & Col_A_C_H & nCol_A_C_G).
	pose proof (lemma_s_ss _ _ _ _ _ _ _ Col_A_C_U Col_A_C_H BetS_E_U_Q BetS_G_H_Q nCol_A_C_E nCol_A_C_G) as SS_E_G_AC.
	exact SS_E_G_AC.
Qed.

End Euclid.


Require Import ZArith ROmega.

(* Submitted by Yegor Bryukhov (#922) *)

Open Scope Z_scope.

(* First a simplified version used during debug of romega on Test46 *)
Lemma Test46_simplified :
forall v1 v2 v5 : Z,
0 = v2 + v5 ->
0 < v5 ->
0 < v2 ->
4*v2 <> 5*v1.
intros.
romega.
Qed.

(* The complete problem *)
Lemma Test46 :
forall v1 v2 v3 v4 v5 : Z,
((2 * v4) + (5)) + (8 * v2) <= ((4 * v4) + (3 * v4)) + (5 * v4) ->
9 * v4 > (1 * v4) + ((2 * v1) + (0 * v2)) ->
((9 * v3) + (2 * v5)) + (5 * v2) = 3 * v4 ->
0 > 6 * v1 ->
(0 * v3) + (6 * v2) <> 2 ->
(0 * v3) + (5 * v5) <> ((4 * v2) + (8 * v2)) + (2 * v5) ->
7 * v3 > 5 * v5 ->
0 * v4 >= ((5 * v1) + (4 * v1)) + ((6 * v5) + (3 * v5)) ->
7 * v2 = ((3 * v2) + (6 * v5)) + (7 * v2) ->
0 * v3 > 7 * v1 ->
9 * v2 < 9 * v5 ->
(2 * v3) + (8 * v1) <= 5 * v4 ->
5 * v2 = ((5 * v1) + (0 * v5)) + (1 * v2) ->
0 * v5 <= 9 * v2 ->
((7 * v1) + (1 * v3)) + ((2 * v3) + (1 * v3)) >= ((6 * v5) + (4)) + ((1) + (9))
-> False.
intros.
romega.
Qed.


Require Export Numbers_facts.

Module mHRw (N:Num_w).

Import N.

Definition P := fun (x:A) => exists n:A, (lim n /\ 0 < n /\  (|x| <= n*w)).

Definition HRw := {x:A | P x }.

Lemma HRw_P : forall x:HRw, P (proj1_sig x).
Proof.
intros x; case x.
simpl; trivial.
Qed.

Lemma P0 : P 0.
Proof.
unfold P.
exists 1.
split.
apply ANS1.
split.
apply lt_0_1.
rewrite mult_neutral.
rewrite abs_pos_val.
apply lt_le.
apply Aw.
apply le_refl.
Qed.

Definition HRw0 : HRw.
exists 0.
apply P0.
Defined.

Lemma P1 : P 1.
Proof.
unfold P.
exists 1.
split.
apply ANS1.
split.
apply lt_0_1.
rewrite mult_neutral.
rewrite abs_pos_val.
setoid_replace 1 with (0+1) by ring.
apply lt_le_2.
apply Aw.
apply lt_le.
apply lt_0_1.
Qed.

Definition HRw1_small : HRw.
exists 1.
apply P1.
Defined.

Lemma Pw : P w.
Proof.
unfold P.
exists 1.
split.
apply ANS1.
split.
apply lt_0_1.
rewrite abs_pos_val.
setoid_replace (1*w) with w by ring.
apply le_refl.
apply lt_le; apply Aw.
Qed.

Definition HRw1 : HRw.
exists w.
apply Pw.
Defined.

End mHRw.