(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra finmap.

(* -------------------------------------------------------------------- *)
Set   Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

(* -------------------------------------------------------------------- *)
Import Order.Theory Order.TTheory Num.Theory.

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

(* -------------------------------------------------------------------- *)
Section FSetMin.
Context (R : realFieldType).

Lemma fset_min_r (S : {fset R}) : S <> fset0 ->
  { x : R | x \in S & (forall y, y \in S -> x <= y) }.
Proof.
elim/finSet_rect: S => S ih /eqP /fset0Pn => h.
have := xchooseP h; move: {h} (xchoose h) => a.
move=> /[dup] aS /fsetD1K /esym SE.
case: ((S `\ a) =P fset0) => [h|{}/ih ih].
- by exists a => // y; rewrite SE h fsetU0 in_fset1 => /eqP->.
case: ih; rewrite ?fproperD1 // => x x_SDa ih.
exists (Num.min a x); first case: lerP => // _.
- by move: x_SDa; rewrite !inE => /andP[].
- move=> y yS; rewrite le_minl; case: lerP => //=.
  move/lt_eqF=> /negbT ne_ya; apply: ih.
  by rewrite !inE ne_ya yS.
Qed.

Definition fset_min (x0 : R) (S : {fset R}) :=
  if S =P fset0 is ReflectF h then
    tag (@fset_min_r _ h)
  else x0.

Lemma fset_min0 x0 : fset_min x0 fset0 = x0.
Proof. by rewrite /fset_min; case: eqP. Qed.

Lemma fset_minP x0 S : S != fset0 ->
  [/\ fset_min x0 S \in S & forall y, y \in S -> fset_min x0 S <= y].
Proof.
move/eqP=> nz_S; rewrite /fset_min; case: eqP => //.
by move=> {}nz_S; case: fset_min_r.
Qed.
End FSetMin.
Section FSetMax.
Context (R : realFieldType).

Definition fset_max (x0 : R) (S : {fset R}) :=
  if S =P fset0 is ReflectF _ then
  - (fset_min x0 [fset -x | x in S]%fset) else x0.

Lemma fset_maxP x0 S : S != fset0 ->
  [/\ fset_max x0 S \in S & forall y, y \in S -> y <= fset_max x0 S].
Proof.
rewrite /fset_max; case: eqP=> //= h _.
have S'0: [fset -x | x in S] != fset0 by
  case/eqP/fset0Pn: h=> x xS; apply/fset0Pn; exists (-x); exact/in_imfset.
case: (fset_minP x0 S'0)=> /imfsetP /= [max] maxS ->; rewrite GRing.opprK maxS.
move=> max_def; split=> // y yS.
move: (max_def (-y)); rewrite in_imfset //=; move/(_ isT).
by rewrite ler_oppl GRing.opprK.
Qed.

Lemma fset_max0 x0: fset_max x0 fset0 = x0.
Proof. by rewrite /fset_max; case: eqP. Qed.

End FSetMax.


Require Import Relations.

Set Implicit Arguments.

Record trsys state := {
  Initial : state -> Prop;
  Step : state -> state -> Prop
}.

Definition invariantFor {state} (sys : trsys state) (invariant : state -> Prop) :=
  forall s, sys.(Initial) s
            -> forall s', sys.(Step)^* s s'
                          -> invariant s'.

Theorem use_invariant : forall {state} (sys : trsys state) (invariant : state -> Prop) s s',
  invariantFor sys invariant
  -> sys.(Step)^* s s'
  -> sys.(Initial) s
  -> invariant s'.
Proof.
  firstorder.
Qed.

Theorem invariant_weaken : forall {state} (sys : trsys state)
  (invariant1 invariant2 : state -> Prop),
  invariantFor sys invariant1
  -> (forall s, invariant1 s -> invariant2 s)
  -> invariantFor sys invariant2.
Proof.
  unfold invariantFor; intuition eauto.
Qed.

Theorem invariant_induction : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  (forall s, sys.(Initial) s -> invariant s)
  -> (forall s, invariant s -> forall s', sys.(Step) s s' -> invariant s')
  -> invariantFor sys invariant.
Proof.
  unfold invariantFor; intros.
  assert (invariant s) by eauto.
  clear H1.
  induction H2; eauto.
Qed.

(** * General parallel composition *)

Record threaded_state shared private := {
  Shared : shared;
  Private : private
}.

Inductive parallel1 shared private1 private2
  (init1 : threaded_state shared private1 -> Prop)
  (init2 : threaded_state shared private2 -> Prop)
  : threaded_state shared (private1 * private2) -> Prop :=
| Pinit : forall sh pr1 pr2,
  init1 {| Shared := sh; Private := pr1 |}
  -> init2 {| Shared := sh; Private := pr2 |}
  -> parallel1 init1 init2 {| Shared := sh; Private := (pr1, pr2) |}.

Inductive parallel2 shared private1 private2
          (step1 : threaded_state shared private1 -> threaded_state shared private1 -> Prop)
          (step2 : threaded_state shared private2 -> threaded_state shared private2 -> Prop)
          : threaded_state shared (private1 * private2)
            -> threaded_state shared (private1 * private2) -> Prop :=
| Pstep1 : forall sh pr1 pr2 sh' pr1',
  step1 {| Shared := sh; Private := pr1 |} {| Shared := sh'; Private := pr1' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1', pr2) |}
| Pstep2 : forall sh pr1 pr2 sh' pr2',
  step2 {| Shared := sh; Private := pr2 |} {| Shared := sh'; Private := pr2' |}
  -> parallel2 step1 step2 {| Shared := sh; Private := (pr1, pr2) |}
               {| Shared := sh'; Private := (pr1, pr2') |}.

Definition parallel shared private1 private2
           (sys1 : trsys (threaded_state shared private1))
           (sys2 : trsys (threaded_state shared private2)) := {|
  Initial := parallel1 sys1.(Initial) sys2.(Initial);
  Step := parallel2 sys1.(Step) sys2.(Step)
|}.

(** * Switching to multistep versions of systems *)

Lemma trc_idem : forall A (R : A -> A -> Prop) x1 x2,
    R^*^* x1 x2
    -> R^* x1 x2.
Proof.
  induction 1; eauto using trc_trans.
Qed.

Theorem invariant_multistepify : forall {state} (sys : trsys state)
  (invariant : state -> Prop),
  invariantFor sys invariant
  -> invariantFor {| Initial := Initial sys; Step := (Step sys)^* |} invariant.
Proof.
  unfold invariantFor; simpl; intuition eauto using trc_idem.
Qed.


(** This file contains the definition of paths over a path, together with some
    facts about them developed by Marc Bezem and Ulrik Buchholtz. *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.MoreFoundations.PartA.

(** ** Paths over paths in families of types *)

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Declare Scope pathsover.
Delimit Scope pathsover with pathsover.
Local Open Scope pathsover.

(** A path in a family of types "over" a path in the base *)
Definition PathOver {X:Type}
           {x x':X} (p:x=x')
           {Y : X -> Type} (y : Y x) (y' : Y x') : Type.
Proof.
  induction p. exact (y=y').
Defined.

(** Paths-over versus path pairs *)
Definition PathOverToPathPair {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x') :
  PathOver p y y' → PathPair (x,,y) (x',,y').
Proof.
  intros q. induction p. exists (idpath x). cbn. exact q.
Defined.

Definition apd {X:Type} {Y : X -> Type} (s : ∏ x, Y x) {x x':X} (p : x = x') :
  PathOver p (s x) (s x').
Proof.
  now induction p.
Defined.

Definition PathOverToTotalPath {X:Type}
           {x x':X} (p:x=x')
           {Y : X -> Type} (y : Y x) (y' : Y x') :
  PathOver p y y' → (x,,y) = (x',,y').
Proof.
  intros q.
  exact (invmap (total2_paths_equiv  Y (x,, y) (x',, y')) (PathOverToPathPair q)).
Defined.

Lemma PathOverUniqueness  {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) :
  ∃! (y' : Y x'), PathOver p y y'.
Proof.
  induction p. apply iscontrcoconusfromt.
Defined.

Definition stdPathOver {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x)
  : PathOver p y (transportf Y p y).
Proof.
  now induction p.
Defined.

Definition stdPathOver' {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y' : Y x')
  : PathOver p (transportb Y p y') y'.
Proof.
  now induction p.
Defined.

Definition identityPathOver {X:Type} {x:X} {Y : X -> Type} (y : Y x)
  : PathOver (idpath x) y y
  := idpath y.

Definition pathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x)
  : PathOver (idpath x) y y' = (y = y')
  := idpath _.

Definition toPathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x)
  : y = y' -> PathOver (idpath x) y y'
  := idfun _.

Local Notation "'∇' q" := (toPathOverIdpath q) (at level 10) : pathsover.

Definition fromPathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) : PathOver (idpath x) y y' -> y = y'
  := idfun _.

Local Notation "'Δ' q" := (fromPathOverIdpath q) (at level 10) : pathsover.

Definition inductionPathOver {X:Type} {x:X} {Y : X -> Type} (y : Y x)
           (T : ∏ x' (p : x = x') (y' : Y x'), PathOver p y y' → Type)
           (t : T x (idpath x) y (identityPathOver y)) :
  ∏ x' (y' : Y x') (p : x = x') (q : PathOver p y y'), T x' p y' q.
Proof.
  intros. induction p, q. exact t.
Defined.

Definition transportPathOver {X:Type} {x x':X} {Y : X -> Type} (y : Y x) (y' : Y x') (p:x=x')
           (q : PathOver p y y')
           (T : ∏ (a:X) (b:Y a), Type) : T x y → T x' y'.
Proof.
  now induction p, q.
Defined.

Definition transportPathOver' {X:Type} {x x':X} (p:x=x') {Y : X -> Type} (y : Y x) (y' : Y x')
           (q : PathOver p y y')
           (T : ∏ (a:X) (b:Y a), Type) : T x' y' → T x y.
Proof.
  now induction p, q.
Defined.

Definition composePathOver {X:Type}
           {x x' x'':X} {p:x=x'} {p':x'=x''}
           {Y : X -> Type} {y : Y x} {y' : Y x'} {y'' : Y x''}
  : PathOver p y y' → PathOver p' y' y'' → PathOver (p @ p') y y''.
Proof.
  induction p, p'. exact pathscomp0.
Defined.

Local Notation "x * y" := (composePathOver x y) : pathsover.

Definition composePathOverPath {X:Type}
           {x x':X} {p:x=x'}
           {Y : X -> Type} {y : Y x} {y' y'' : Y x'}
  : PathOver p y y' → y' = y'' → PathOver p y y''.
Proof.
  intros q e. now induction e.
Defined.

Local Notation "q ⟥ e" := (composePathOverPath q e) (at level 56, left associativity) : pathsover.

Definition composePathOverIdpath {X:Type}
           {x x':X} {p:x=x'}
           {Y : X -> Type} {y : Y x} {y': Y x'}
           (q : PathOver p y y')
  : q ⟥ idpath y' = q.
Proof.
  reflexivity.
Defined.

Definition composePathPathOver {X:Type}
           {x' x'':X} {p:x'=x''}
           {Y : X -> Type} {y y': Y x'} {y'' : Y x''}
  : y = y' → PathOver p y' y'' → PathOver p y y''.
Proof.
  intros e q. now induction e.
Defined.

Local Notation "e ⟤ q" := (composePathPathOver e q) (at level 56, left associativity) : pathsover.

Lemma composeIdpathPathOver {X:Type}
      {x' x'':X} {p:x'=x''}
      {Y : X -> Type} {y': Y x'} {y'' : Y x''}
      (q : PathOver p y' y'')
  : idpath y' ⟤ q = q.
Proof.
  reflexivity.
Defined.

Lemma composePathPathOverRotate {X:Type}
      {x' x'':X} {p:x'=x''}
      {Y : X -> Type} {y y': Y x'} (q : y = y') {y'' : Y x''}
      (r : PathOver p y' y'') (s : PathOver p y y'')
  : q ⟤ r = s <-> r = (!q) ⟤ s.
Proof.
  induction q. simpl. apply isrefl_logeq.
Defined.

Lemma composePathOverPathRotate {X:Type}
      {x x':X} {p:x=x'}
      {Y : X -> Type} {y : Y x} {y' y'': Y x'}
      (r : PathOver p y y') (q : y' = y'') (s : PathOver p y y'')
  : r ⟥ q = s <-> r = s ⟥ (!q).
Proof.
  induction q. simpl. apply isrefl_logeq.
Defined.

Lemma composePathPathOverPath {X:Type}
      {x x':X} {p:x=x'}
      {Y : X -> Type} {y y' : Y x} {y'' y''': Y x'} (q : y = y') (r : PathOver p y' y'') (s : y'' = y''')
  : q ⟤ (r ⟥ s) = (q ⟤ r) ⟥ s.
Proof.
  now induction q.
Defined.

Definition composePathOverLeftUnit {X:Type}
           {x x':X} (p:x=x')
           {Y : X -> Type} (y : Y x) (y' : Y x') (q:PathOver p y y') :
  identityPathOver y * q = q.
Proof.
  now induction p.
Defined.

Definition composePathOverRightUnit {X:Type}
           {x x':X} (p:x=x')
           {Y : X -> Type} (y : Y x) (y' : Y x') (q:PathOver p y y') :
  q * identityPathOver y' = transportb (λ p, PathOver p y y') (pathscomp0rid _) q.
Proof.
  now induction p, q.
Defined.

Definition assocPathOver {X:Type}
           {x x' x'' x''':X} {p:x=x'} {p':x'=x''} {p'':x''=x'''}
           {Y : X -> Type} {y : Y x} {y' : Y x'} {y'' : Y x''} {y''' : Y x'''}
           (q : PathOver p y y') (q' : PathOver p' y' y'') (q'' : PathOver p'' y'' y''') :
  transportf (λ ppp, PathOver ppp y y''') (path_assoc p p' p'') (q * (q' * q''))
  =
  (q * q') * q''.
Proof.
  induction p, p', p'', q, q', q''. reflexivity.
Defined.

Definition inversePathOver {X:Type}
           {x x':X} {p:x=x'}
           {Y : X -> Type} {y : Y x} {y' : Y x'}
  : PathOver p y y' → PathOver (!p) y' y.
Proof.
  intros q. induction p, q. reflexivity.
Defined.

Definition inversePathOver' {X:Type}
           {x x':X} {p:x'=x}
           {Y : X -> Type} {y : Y x} {y' : Y x'}
  : PathOver (!p) y y' → PathOver p y' y.
Proof.
  intros q. induction p, q. reflexivity.
Defined.

Definition inverseInversePathOver1 {X:Type}
           {x x':X} {p:x=x'}
           {Y : X -> Type} {y : Y x} {y' : Y x'}
           (s : PathOver p y y')
  : inversePathOver' (inversePathOver s) = s.
Proof.
  induction p, s. reflexivity.
Defined.

Definition inverseInversePathOver2 {X:Type}
           {x x':X} {p:x'=x}
           {Y : X -> Type} {y : Y x} {y' : Y x'}
           (s : PathOver (!p) y y')
  : inversePathOver (inversePathOver' s) = s.
Proof.
  induction p, s. reflexivity.
Defined.

Local Notation "q '^-1'" := (inversePathOver q) : pathsover.

Definition inversePathOverIdpath {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) (e : y = y') :
  inversePathOver (∇ e) = ∇ (!e).
Proof.
  reflexivity.
Defined.

Definition inversePathOverIdpath' {X:Type} {x:X} {Y : X -> Type} (y y' : Y x) (e : y = y') :
  inversePathOver' (∇ e : PathOver (! idpath x) y y') = ∇ (!e).
Proof.
  reflexivity.
Defined.

Definition inverseInversePathOver {X:Type} {Y : X -> Type} {x:X} {y : Y x} :
  ∏ {x':X} {y' : Y x'} {p:x=x'} (q : PathOver p y y'),
  transportf (λ pp, PathOver pp y y') (pathsinv0inv0 p) (q^-1^-1) = q.
Proof.
  now use inductionPathOver.
Defined.

Definition inversePathOverWeq {X:Type}
           {x x':X} {p:x=x'}
           {Y : X -> Type} {y : Y x} {y' : Y x'}
  : PathOver p y y' ≃ PathOver (!p) y' y.
Proof.
  (* compare with weqpathsinv0 *)
  exists inversePathOver. intros s. use tpair.
  - exists (inversePathOver' s). apply inverseInversePathOver2.
  - cbn. induction p. intros [t []]. induction t. reflexivity.
Defined.

Lemma inversePathOverWeq' {X:Type}
           {x x':X} {p:x'=x}
           {Y : X -> Type} {y : Y x} {y' : Y x'}
  : PathOver (!p) y y' ≃ PathOver p y' y.
Proof.
  (* compare with weqpathsinv0 *)
  exists inversePathOver'. intros s. use tpair.
  - exists (inversePathOver s). apply inverseInversePathOver1.
  - cbn. induction p. intros [t []]. induction t. reflexivity.
Defined.

(** Paths-over in a constant family *)

Definition PathOverConstant_id {X:Type} {x x':X} (p:x=x') {Z : Type} (z : Z) (z' : Z)
  : (z = z') = (PathOver p z z').
Proof.
  now induction p.
Defined.

Definition PathOverConstant_map1 {X:Type} {x x':X} (p:x=x') {Z : Type} {z z' : Z}
  : z = z' -> PathOver p z z'.
Proof.
  now induction p.
Defined.

Definition PathOverConstant_map1_eq1 {X:Type}
           {x x':X} (p:x=x')
           {Z : Type} {z z' z'' : Z}
           (q: z = z') (r : z' = z'')
  : PathOverConstant_map1 p (q @ r) = PathOverConstant_map1 p q ⟥ r.
Proof.
  now induction r, q.
Defined.

Definition PathOverConstant_map1_eq2 {X:Type}
           {x x':X} (p:x=x')
           {Z : Type} {z z' z'' : Z}
           (q: z = z') (r : z' = z'')
  : PathOverConstant_map1 p (q @ r) = q ⟤ PathOverConstant_map1 p r.
Proof.
  now induction r, q.
Defined.

Definition PathOverConstant_map2 {X:Type}
           {x x':X} {p:x=x'}
           {Z : Type} {z z' : Z}
  : PathOver p z z' -> z = z'.
Proof.
  now induction p.
Defined.

Definition PathOverConstant_map2_apd {X:Type}
           {x x':X} {p:x=x'}
           {Z : Type} {f : X -> Z}
  : PathOverConstant_map2 (apd f p) = maponpaths f p.
Proof.
  now induction p.
Defined.

Definition PathOverConstant_map2_eq1 {X:Type}
           {x x':X} {p:x=x'}
           {Z : Type} {z z' z'' : Z}
           (q: PathOver p z z') (r : z' = z'')
  : PathOverConstant_map2 (q ⟥ r) = PathOverConstant_map2 q @ r.
Proof.
  induction r. change (q ⟥ idpath z') with q. apply pathsinv0, pathscomp0rid.
Defined.

Definition PathOverConstant_map2_eq2 {X:Type}
           {x x':X} (p:x=x')
           {Z : Type} {z z' z'' : Z}
           (r : z = z') (q: PathOver p z' z'')
  : PathOverConstant_map2 (r ⟤ q) = r @ PathOverConstant_map2 q.
Proof.
  now induction r.
Defined.

Lemma PathOverConstant_map1_map2 {X:Type}
      {x x':X} (p:x=x')
      {Z : Type} {z z' : Z} (q : z = z')
  : PathOverConstant_map2 (PathOverConstant_map1 p q) = q.
Proof.
  now induction p.
Defined.

(** lemmas *)

Lemma Lemma023 (A:Type) (B:A->Type) (a1 a2 a3:A)
      (b1:B a1) (b2:B a2) (b3:B a3)
      (p1:a1=a2) (p2:a2=a3)
      (q:PathOver p1 b1 b2) :
  isweq (composePathOver q : PathOver p2 b2 b3 -> PathOver (p1@p2) b1 b3).
Proof.
  induction p1, p2, q. apply idisweq.
Defined.

Definition composePathOver_weq (A:Type) (a1 a2 a3:A) (B:A->Type)
      (b1:B a1) (b2:B a2) (b3:B a3)
      (p1:a1=a2) (p2:a2=a3)
      (q:PathOver p1 b1 b2)
  : PathOver p2 b2 b3 ≃ PathOver (p1@p2) b1 b3
  := make_weq (composePathOver q) (Lemma023 _).

Lemma Lemma0_2_4 (A:Type) (B:A->Type) (a1 a2:A)
      (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q) :
  isweq ((transportf (λ pp, PathOver pp b1 b2) α) : PathOver p b1 b2 -> PathOver q b1 b2).
Proof.
  induction α. apply idisweq.
Defined.

Definition cp                   (* "change path" *)
           (A:Type) (a1 a2:A) (p q:a1=a2) (α : p=q)
           (B:A->Type) (b1:B a1) (b2:B a2) :
  PathOver p b1 b2 ≃ PathOver q b1 b2
  := make_weq (transportf (λ pq, PathOver pq b1 b2) α) (Lemma0_2_4 α).

Arguments cp {_ _ _ _ _} _ {_ _ _}.

Definition composePathOverPath_compute {X:Type}
           {x x':X} {p:x=x'}
           {Y : X -> Type} {y : Y x} {y' y'' : Y x'}
           (q : PathOver p y y') (e : y' = y'') :
  q ⟥ e = cp (pathscomp0rid p) (q * ∇ e).
Proof.
  now induction p, q, e.
Defined.

Definition composePathPathOver_compute {X:Type}
           {x' x'':X} {p:x'=x''}
           {Y : X -> Type} {y y': Y x'} {y'' : Y x''}
           (e : y = y') (q : PathOver p y' y'') :
  e ⟤ q = ∇ e * q.
Proof.
  now induction p.
Defined.

Definition cp_idpath
           (A:Type) (a1 a2:A) (p:a1=a2)
           (B:A->Type) (b1:B a1) (b2:B a2) (u:PathOver p b1 b2) :
  cp (idpath p) u = u.
Proof.
  reflexivity.
Defined.

Definition cp_left
           (A:Type) (a2 a3:A) (p p':a2=a3) (α:p=p')
           (B:A->Type) (b1 b2:B a2) (b3:B a3)
           (r:PathOver (idpath a2) b1 b2)
           (q:PathOver p b2 b3) :
  r * cp α q = cp α (r*q).
Proof.
  now induction r, α.
Defined.

Definition cp_right
           (A:Type) (a1 a2:A) (p p':a1=a2) (α:p=p')
           (B:A->Type) (b1:B a1) (b2 b3:B a2)
           (q:PathOver p b1 b2)
           (r:PathOver (idpath a2) b2 b3) :
  cp α q * r = cp (maponpaths (λ p, p @ idpath a2) α) (q*r).
Proof.
  now induction r, α.
Defined.

Definition cp_in_family
           (A:Type) (a1 a2:A)
           (T:Type) (t0 t1:T) (v:t0=t1) (p:T->a1=a2)
           (B:A->Type) (b1:B a1) (b2:B a2) (s : ∏ t, PathOver (p t) b1 b2) :
  cp (maponpaths p v) (s t0) = s t1.
Proof.
  now induction v.
Defined.

Definition cp_irrelevance
           (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α β: p=q) :
  isofhlevel 3 A -> cp (b1:=b1) (b2:=b2) α = cp (b1:=b1) (b2:=b2) β.
Proof.
  intros ih. apply (maponpaths (λ α, cp α)). apply ih.
Defined.

Local Goal ∏ (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2) (p q:a1=a2) (α : p=q)
      (r : PathOver p b1 b2) (s : PathOver q b1 b2),
  (cp α r = s) = (PathOver (Y := λ pq, PathOver pq _ _) α r s).
Proof.
  intros. induction α, p. reflexivity.
Defined.

Definition inverse_cp_p
           (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2)
           (p q:a1=a2) (α : p=q) (t : PathOver p b1 b2) :
  cp (! α) (cp α t) = t.
Proof.
  now induction α.
Defined.

Definition inverse_cp_p'
           (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2)
           (p q:a1=a2) (α : p=q)
           (t : PathOver p b1 b2) (u : PathOver q b1 b2) :
  PathOver (Y := λ pq, PathOver pq _ _) α t u -> PathOver (Y := λ pq, PathOver pq _ _) (!α) u t.
Proof.
  exact inversePathOver.
Defined.

Definition inverse_cp_p''
           (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2)
           (p q:a1=a2) (α : p=q)
           (t : PathOver p b1 b2) (u : PathOver q b1 b2) :
  PathOver (Y := λ pq, PathOver pq _ _) α t u -> PathOver (Y := λ pq, PathOver pq _ _) (!α) u t.
Proof.
  intros k. induction α, p, k. reflexivity.
Defined.

Lemma inverse_cp_p_compare
           (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2)
           (p q:a1=a2) (α : p=q)
           (t : PathOver p b1 b2) (u : PathOver q b1 b2)
           (k : PathOver α t u) :
  inverse_cp_p' k = inverse_cp_p'' k.
Proof.
  induction α,p. reflexivity.
Defined.

Definition cp_inverse_cp
           (A:Type) (B:A->Type) (a1 a2:A) (b1:B a1) (b2:B a2)
           (p q:a1=a2) (α : p=q) (t : PathOver q b1 b2) :
  cp α (cp (! α) t) = t.
Proof.
  now induction α.
Defined.

Definition composePathOverRightInverse {X:Type} {x x':X} {Y : X -> Type}
           {y : Y x} {y' : Y x'} {p:x=x'} (q : PathOver p y y') :
  q * q^-1 = cp (!pathsinv0r p) (identityPathOver y).
Proof.
  now induction p, q.
Defined.

Definition composePathOverLeftInverse {X:Type} {x x':X} {Y : X -> Type}
           {y : Y x} {y' : Y x'} {p:x=x'} (q : PathOver p y y') :
  q^-1 * q = cp (!pathsinv0l p) (identityPathOver y').
Proof.
  now induction p, q.
Defined.

Lemma cp_pathscomp0
      (A:Type) (B:A->Type) (a1 a2:A)
      (b1:B a1) (b2:B a2) (p q r:a1=a2) (α : p=q) (β : q=r)
      (s : PathOver p b1 b2) :
  cp (b1:=b1) (b2:=b2) (α @ β) s = cp β (cp α s).
Proof.
  now induction α.
Defined.

(* a frequently-useful specialisation of [maponpaths_12] *)
Definition apstar               (* 0.2.7 *)
           (A:Type) (a1 a2 a3:A) (p p':a1=a2) (q q':a2=a3) :
  p=p' -> q=q' -> p @ q = p' @ q'.
Proof.
  intros; apply maponpaths_12; assumption.
Defined.

Definition cp_apstar
      (A:Type) (B:A->Type) (a1 a2 a3:A)
      (p p':a1=a2) (q q':a2=a3) (α : p=p') (β : q=q')
      (b1:B a1) (b2:B a2) (b3:B a3)
      (pp : PathOver p b1 b2) (qq : PathOver q b2 b3) :
  cp (apstar α β) (pp * qq) = cp α pp * cp β qq.
Proof.
  now induction p, α, β.
Defined.

Definition cp_apstar'
      (A:Type) (B:A->Type) (a1 a2:A)
      (p:a2=a1) (p':a1=a2) (α : !p=p')
      (b1:B a1) (b2:B a2)
      (pp : PathOver (Y:=B) p b2 b1) :
  cp α (pp^-1) = inversePathOver' (cp (invrot α) pp).
Proof.
  now induction α, p.
Defined.

(* what a path-over is in a family of equations *)
Lemma pathOverEquations {X Y:Type} {f g : X -> Y} {x x' : X} (e : f x = g x) (e' : f x' = g x') (p : x = x')
  : PathOver (Y := λ x, f x = g x) p e e' = ( e @ maponpaths g p = maponpaths f p @ e' ).
Proof.
  induction p. simpl. apply (maponpaths (λ r, r = e')). apply pathsinv0, pathscomp0rid.
Defined.

Lemma pathOverEquations1 {X:Type} {f : X -> X} {x x' : X} (e : f x = x) (e' : f x' = x') (p : x = x')
  : PathOver (Y := λ x, f x = x) p e e' = ( e @ p = maponpaths f p @ e' ).
Proof.
  induction p. simpl. apply (maponpaths (λ r, r = e')). apply pathsinv0, pathscomp0rid.
Defined.

(* functoriality *)
Definition mapPathOver {X:Type} {x x':X} (p:x=x')
           {Y Y': X -> Type} (f : ∏ x, Y x -> Y' x)
           (y : Y x) (y' : Y x')
  : PathOver p y y' -> PathOver p (f x y) (f x' y').
Proof.
  induction p. simpl. intros []. reflexivity.
Defined.

Definition binopPathOver {X:Type}
           {x x':X} (p:x=x')
           {Y Z W : X -> Type} (f : ∏ x, Y x -> Z x -> W x)
           (y : Y x) (y' : Y x')
           (z : Z x) (z' : Z x')
  : PathOver p y y' -> PathOver p z z' -> PathOver p (f x y z) (f x' y' z').
Proof.
  induction p. simpl. intros [] []. reflexivity.
Defined.

Local Unset Implicit Arguments.

Definition pullBackFamily {X X':Type} (g : X -> X') (Y : X' -> Type)
  := λ x, Y (g x).

Definition pullBackSection {X X':Type} (g : X -> X') {Y : X' -> Type} (f : ∏ x', Y x')
  := λ x, f (g x).

Definition pullBackPointOver {X X':Type} (g : X -> X')
           {x:X} {x':X'} (r : g x = x')
           {Y : X' -> Type} (y : Y x')
  : (pullBackFamily g Y) (x).
Proof.
  induction r. exact y.
Defined.

Definition pullBackPointOverWithSection {X X':Type} (g : X -> X')
           {x:X} {x':X'} (r : g x = x') {Y : X' -> Type} (f : ∏ x', Y x')
  : pullBackPointOver g r (f x') = pullBackSection g f x.
Proof.
   induction r. reflexivity.
Defined.

Definition pullBackPointOverWithSection' (* redundant? *)
           {X X':Type} (g : X -> X')
           {x:X} {x':X'} (r : g x = x')
           {Y : X' -> Type} {y : Y x'}
           {f : ∏ x', Y x'} (k : y = f x')
  : pullBackPointOver g r y = pullBackSection g f x.
Proof.
  induction (!k), r. reflexivity.
Defined.

Definition pullBackPathOverPoint {X X':Type} (g : X -> X')
           {x:X} {x':X'} (r : g x = x')
           {Y : X' -> Type} {y y' : Y x'} (t : y = y')
  : pullBackPointOver g r y = pullBackPointOver g r y'.
Proof.
  apply maponpaths; assumption.
Defined.

Definition pullBackPathOver {X X':Type} (g : X -> X')
           {x1 x2:X} {x1' x2':X'} {r1 : g x1 = x1'} {r2 : g x2 = x2'}
           {s : x1 = x2} {s' : x1' = x2'}
           (r : r1 @ s' = maponpaths g s @ r2)
           {Y : X' -> Type}
           {y1 : Y x1'} {y2 : Y x2'}
           (q : PathOver s' y1 y2)
  : PathOver s (pullBackPointOver g r1 y1) (pullBackPointOver g r2 y2).
Proof.
  induction r1, r2. simpl in r; simpl.
  assert (k' : s' = maponpaths g s). { refine (r @ pathscomp0rid _). } clear r.
  induction (!k'); clear k'. induction s. simpl in q. simpl. exact q.
Defined.

Definition pullBackPathOverPath {X X':Type} (g : X -> X')
           {x1 x2:X} {x1' x2':X'} {r1 : g x1 = x1'} {r2 : g x2 = x2'}
           {s : x1 = x2} {s' : x1' = x2'}
           (r : r1 @ s' = maponpaths g s @ r2)
           {Y : X' -> Type}
           (y1 : Y x1') (y2 y3 : Y x2')
           (q : PathOver s' y1 y2)
           (t : y2 = y3)
  : pullBackPathOver g r (q ⟥ t) = pullBackPathOver g r q ⟥ pullBackPathOverPoint g r2 t.
Proof.
  induction t, r1, r2. reflexivity.
Defined.

Definition pullBackPathPathOver {X X':Type} (g : X -> X')
           {x1 x2:X} {x1' x2':X'} (r1 : g x1 = x1') (r2 : g x2 = x2')
           (s : x1 = x2) (s' : x1' = x2')
           (r : r1 @ s' = maponpaths g s @ r2)
           {Y : X' -> Type}
           (y0 y1 : Y x1') (y2 : Y x2')
           (q : PathOver s' y1 y2)
           (t : y0 = y1)
  : pullBackPathOver g r (t ⟤ q) = pullBackPathOverPoint g r1 t ⟤ pullBackPathOver g r q.
Proof.
  induction t, r1, r2. reflexivity.
Defined.

Module PathsOverNotations.
Notation "'Δ' q" := (fromPathOverIdpath q) (at level 10) : pathsover.
Notation "'∇' q" := (toPathOverIdpath q) (at level 10) : pathsover.
Notation "x * y" := (composePathOver x y) : pathsover.
Notation "q ⟥ e" := (composePathOverPath q e) (at level 56, left associativity) : pathsover.
Notation "e ⟤ q" := (composePathPathOver e q) (at level 56, left associativity) : pathsover.
Notation "q '^-1'" := (inversePathOver q) : pathsover.
End PathsOverNotations.


Require Export SystemFR.Notations.
Require Export SystemFR.Evaluator.
Require Extraction.
Import Notations.UnTyped.

Definition natEq_example := Eval compute in
  [|
   let natEq := (
         def_rec f x y =>
         match x with
         | 0 => (match y with
               | 0 => t_true
               | s y' => t_false end)
         | s x' =>(
           match y with
           | 0 =>  t_false
           | s y' => (f x' y')
           end)
         end) in
   let boolAnd := (fun a => fun b => if (a) then b else t_false) in
   let oddEven := def_rec f p x => match p with
                                 | 0 => match x with
                                       | 0 => t_true
                                       | s x' => f 1 x' end
                                 | s p' => match x with
                                          | 0 => t_false
                                          | s x' => f 0 x'
                                          end
                                 end
   in
   let oddEven1 := def_rec f x => (
                     (match x with | 0 => t_true  | s x' => ((f x')._2) end),
                     (match x with | 0 => t_false | s x' => ((f x')._1) end)
                   ) in
   let isEven := oddEven 0 in
   let isOdd := oddEven 1 in
   let isEven1 := (fun x => ((oddEven1 x)._1)) in
   let isOdd1 := (fun x => ((oddEven1 x)._2)) in

   boolAnd (isEven 0)
           (boolAnd (isEven1 0)
                    (boolAnd (isOdd 1)
                             (boolAnd (isOdd1 1)
                                      (boolAnd (isEven 2)
                                               (boolAnd (isEven1 2)
                                                        (boolAnd (isOdd 3)
                                                                 (isOdd1 3)))))))
    |].

Print natEq_example.

Example isEven: (eval natEq_example 10000) = Some ttrue.
Proof.
  native_compute.
  reflexivity. Qed.

(*
(* Extraction *)
Extraction Language Ocaml.
Set Extraction AccessOpaque.

Definition isEven := natEq_example.
Extraction "isEven.ml" isEven eval.
*)


Inductive nel (A : Type) : Type :=
| singl : A -> nel A
| ncons : A -> nel A -> nel A.

Arguments singl [A] _.
Arguments ncons [A] _ _.

Fixpoint last {A : Type} (l : nel A) : A :=
match l with
| singl x => x
| ncons _ t => last t
end.

Fixpoint len {A : Type} (l : nel A) : nat :=
match l with
| singl _ => 1
| ncons _ l' => S (len l')
end.

(* PNNS stands for PositionalNaturalNumberSystem. *)
Class PNNS : Type :=
{
  digit : Type;
  weight : nat -> nat;
  dvalue : digit -> nat;
}.

(* A number in some PNNS is a nonempty sequence of digits (with the least
   significant digit at the head of the list) such that the value of the
   most significant digit (i. e. the last one) is not zero. *)
Definition num (sys : PNNS) : Type :=
  {l : nel digit | dvalue (last l) <> 0}.

Fixpoint nvalue_aux {sys : PNNS} (ds : nel digit) (i : nat) : nat :=
match ds with
| singl d => dvalue d * weight i
| ncons d ds' => dvalue d * weight i + nvalue_aux ds' (S i)
end.

Definition nvalue {sys : PNNS} (n : num sys) : nat :=
  nvalue_aux (proj1_sig n) 0.

#[export]
Instance unary : PNNS :=
{
  digit := unit;
  weight := fun _ => 1;
  dvalue tt := 1
}.

Lemma nvalue_aux_len :
  forall (ds : nel unit) (i : nat),
    @nvalue_aux unary ds i = len ds.
Proof.
  induction ds as [d | d ds']; cbn; intros; rewrite ?IHds'; reflexivity.
Qed.

Lemma nvalue_len :
  forall n : num unary,
    nvalue n = len (proj1_sig n).
Proof.
  destruct n. cbn. apply nvalue_aux_len.
Qed.

Definition nat_to_unary (n : nat) : num unary.
Proof.
  induction n as [| n'].
    exists (singl tt). cbn. congruence.
    destruct IHn' as [ds H]. exists (ncons tt ds). cbn. congruence.
Defined.

Definition complete (sys : PNNS) : Prop :=
  forall n : nat, exists rep : num sys, nvalue rep = n.

Lemma unary_not_complete :
  ~ complete unary.
Proof.
  unfold complete. intro. destruct (H 0) as [[ds wut] H'].
  cbn in *; clear wut. destruct ds; cbn in H'; congruence.
Qed.

Definition redundant (sys : PNNS) : Prop :=
  exists rep1 rep2 : num sys,
    proj1_sig rep1 <> proj1_sig rep2 /\ nvalue rep1 = nvalue rep2.

Lemma unary_nvalue_aux_inj :
  forall (ds1 ds2 : nel (@digit unary)) (i : nat),
    nvalue_aux ds1 i = nvalue_aux ds2 i -> ds1 = ds2.
Proof.
  induction ds1 as [[] | [] ds1'];
  destruct ds2 as [[] | [] ds2']; cbn in *; intros.
    reflexivity.
    destruct ds2'; cbn in H; try congruence.
    destruct ds1'; cbn in H; try congruence.
    f_equal. inversion H. exact (IHds1' _ _ H1).
Qed.

Lemma unary_not_redundant :
  ~ redundant unary.
Proof.
  unfold redundant. intro.
  destruct H as [[ds1 H1] [[ds2 H2] [H H']]]; cbn in *; clear H1 H2.
  apply unary_nvalue_aux_inj in H'. contradiction.
Qed.


Require Import Prelim.

(** ** PCP and MPCP *)

Section pcp_definition.
  Variable X:Type.

  Definition pcp : Type := list (list X * list X).
  Definition mpcp : Type := (list X * list X) * pcp.

  Definition trans_mpcp_pcp : mpcp -> pcp := fun M => (fst M)::(snd M).
  Coercion trans_mpcp_pcp : mpcp >-> pcp.

  Definition solution (P:pcp) :=
    concat (map fst P) = concat (map snd P).

  Definition pcp_solution P S :=
    S <> nil /\ S <<= P /\ solution S.

  Definition MPCP (M: mpcp) := exists S, pcp_solution (fst M::snd M) ((fst M)::S).
  Definition PCP (P: pcp) := exists S, pcp_solution P S.

End pcp_definition.

Definition PCPD (S: sigT (fun X => pcp X)) := PCP (projT2 S).
Definition MPCPD (S: sigT (fun X => mpcp X)) := MPCP (projT2 S).


Require Export D6_SumAnglesProp.

Require Export Omega.

Section DISTINCT_PARALLEL.

Lemma ThreeEmbeddedTriangles : forall A B C D E F G : Point,
	Clockwise A B C ->
	HalfLine A B D ->
	HalfLine A C E ->
	Angle A B C = Angle A D E ->
	Angle A C B = Angle A E D ->
	Between A D F ->
	Between A E G ->
	Distance D F = Distance A B ->
	Distance E G = Distance A C ->
	Angle A B C = Angle A F G /\ Angle A C B = Angle A G F.
Proof.
	intros.
	assert (H8 : Clockwise E D F).
	 generalizeChangeSense.
	   apply ClockwiseCAB; apply H9; apply H0.
	   apply ClockwiseBCA; apply H11; autoClockwise.
	 destruct (ExistsDParallelogramm _ _ _ H8) as (I, H9).
	   assert (CongruentStrictTriangles A B C E I G).
	  apply CongruentStrictTrianglesSASA.
	   assert (H10 := ParallelogrammCongruentTrianglesAC _ _ _ _ (ParallelogrammPermut _ _ _ _ H9)).
	     rewrite (DistSym E I); rewrite <- (CongruentStrictTrianglesAB _ _ _ _ _ _ H10); auto.
	   auto.
	   apply sym_eq; apply (SumAnglesCorollary E A D I G B C A).
	    autoClockwise.
	    generalizeChangeSense.
	      apply H13; apply ClockwiseCAB; apply H0; autoClockwise.
	    apply ClockwiseCAB; exact (ParallelogrammClockwiseBDA _ _ _ _ H9).
	    rewrite <- H3; apply AngleSym.
	     autoDistinct.
	     autoDistinct.
	    rewrite (AngleSym E).
	     rewrite (ExternParallelogramm I E D F A).
	      rewrite (AngleSym D).
	       rewrite (AngleSym B); auto; autoDistinct.
	       autoDistinct.
	       exact (sym_not_eq (BetweenDistinctAB _ _ _ H4)).
	      do 3 apply ParallelogrammPermut; trivial.
	      exact (BetweenSym _ _ _ H4).
	     autoDistinct.
	     exact (sym_not_eq (ParallelogrammDistinctCD _ _ _ _ (ParallelogrammPermut _ _ _ _ H9))).
	    trivial.
	   exact (ClockwiseNotCollinear _ _ _ H).
	  assert (H11 : Between F I G).
	   apply (SupplementaryRec I F E G).
	    apply (ParallelogrammClockwiseBCD _ _ _ _ (ParallelogrammPermut _ _ _ _ H9)).
	    apply ClockwiseBCA; apply (EquiOrientedRev _ _ _ (BetweenSym _ _ _ H5)).
	      canonize; apply ClockwiseBCA.
	      apply (HalfLineParallel I E D F A).
	     do 3 apply ParallelogrammPermut; trivial.
	     apply BetweenSymHalfLine; canonize.
	    rewrite <- (CongruentStrictTrianglesB _ _ _ _ _ _ H10); rewrite H2.
	      rewrite <- (CongruentStrictTrianglesB _ _ _ _ _ _ (ParallelogrammCongruentTrianglesAC _ _ _ _ H9)).
	      apply SupplementaryCommut; exists D; exists A; exists E; exists F; intuition.
	      autoDistinct.
	   split.
	    rewrite (HalfLineAngleBC F A G D I).
	     rewrite (ExternOppParallelogramm D F I E G).
	      exact (CongruentStrictTrianglesB _ _ _ _ _ _ H10).
	      exact (ParallelogrammPermut _ _ _ _ H9).
	      trivial.
	     exact (BetweenDistinctCA _ _ _ H4).
	     apply sym_not_eq; exact (BetweenDistinctCA _ _ _ H11).
	     apply HalfLineSym.
	      autoDistinct.
	      exact (BetweenSymHalfLine _ _ _ H4).
	     apply HalfLineSym.
	      exact (BetweenDistinctAB _ _ _ H11).
	      exact (BetweenHalfLine _ _ _ H11).
	    rewrite (HalfLineAngleBC G A F E I).
	     exact (CongruentStrictTrianglesC _ _ _ _ _ _ H10).
	     exact (BetweenDistinctCA _ _ _ H5).
	     exact (BetweenDistinctCA _ _ _ H11).
	     apply HalfLineSym.
	      apply sym_not_eq; exact (BetweenDistinctBC _ _ _ H5).
	      exact (BetweenSymHalfLine _ _ _ H5).
	     apply HalfLineSym.
	      apply sym_not_eq; exact (BetweenDistinctBC _ _ _ H11).
	      exact (BetweenSymHalfLine _ _ _ H11).
Qed.

Lemma EmbeddedSimilarTriangles : forall A B C : Point, forall n : nat,
	Clockwise A B C ->
	n > 0 ->
	forall D E : Point,
		HalfLine A B D ->
		HalfLine A C E ->
		Distance A D = DistTimesn n A B ->
		Distance A E = DistTimesn n A C ->
		Angle A B C = Angle A D E /\ Angle A C B = Angle A E D.
Proof.
	intros A B C n H Hn.
	assert (Hab := ClockwiseDistinctAB _ _ _ H).
	assert (Hac := sym_not_eq (ClockwiseDistinctCA _ _ _ H)).
	induction Hn.
	 simpl in |- *; rewrite NullDist; do 2 rewrite LS0NeutralRight; intros.
	   rewrite (HalfLineEquidistantEqual A B D Hab H0 (sym_eq H2)).
	   rewrite (HalfLineEquidistantEqual A C E Hac H1 (sym_eq H3)).
	   auto.
	 destruct (StrongGraduation A B Hab m) as (Dm, (H0, (H1, H2))).
	   destruct (StrongGraduation A C Hac m) as (Em, (H3, (H4, H5))).
	   assert (A <> Dm).
	  apply H2; omega.
	  assert (A <> Em).
	   apply H5; omega.
	   destruct
	    (IHHn Dm Em (HalfLineSym _ _ _ H6 H0) (HalfLineSym _ _ _ H7 H3) H1 H4).
	     clear IHHn H2 H5; simpl in |- *; intros.
	     destruct (ExistsEquidistantBetween A Dm A B H6 Hab) as (DSm, (H12, H13)).
	     assert
	      (H14 :=
	       HalfLineEquidistantEqualPoints _ _ _ _ _ _ H0 H1 H2 H6 H10 H12 H13);
	      subst.
	     subst.
	     destruct (ExistsEquidistantBetween A Em A C H7 Hac) as (ESm, (H14, H15)).
	     assert
	      (H16 :=
	       HalfLineEquidistantEqualPoints _ _ _ _ _ _ H3 H4 H5 H7 H11 H14 H15);
	      subst.
	     apply (ThreeEmbeddedTriangles A B C Dm Em D E); auto.
	    apply (HalfLineSym _ _ _ H6 H0).
	    apply (HalfLineSym _ _ _ H7 H3).
Qed.

Lemma ExistsClockwiseParallelogramm : forall A B C D E : Point,
	Parallelogramm A B C D ->
	Between D E A ->
	exists F : Point, Collinear C E F /\ Clockwise B A F.
Proof.
	intros.
	destruct (ExistsDParallelogramm C D E) as (G, H1).
	 apply ClockwiseCAB; apply (BetweenClockwiseAMC D A C E).
	  unfold Parallelogramm in *; intuition; autoClockwise.
	  trivial.
	 assert (H2 := ParallelogrammClockwiseBCD _ _ _ _ H1).
	   destruct (PaschABC D A C E G) as [(I, (H3, H4))| (I, (H3, H4))].
	  unfold Parallelogramm in *; intuition; autoClockwise.
	  trivial.
	  apply ClockwiseNotCollinear; exact H2.
	  intro; elim (ClockwiseNotCollinear E A G).
	   canonize.
	   autoCollinear.
	  unfold Parallelogramm in *; intuition; autoClockwise.
	  elim (BetweenNotClockwiseABC D I C H4).
	    apply ClockwiseBCA; destruct (CollinearHalfLine _ _ _ H3).
	   apply (ParallelHalfLine _ _ _ _ _ H1 H5).
	   apply (HalfLineParallel _ _ _ _ _ H1 H5).
	  assert (H5 := sym_not_eq (BetweenDistinctBC _ _ _ H4)).
	    destruct (Archimedian C I A H5) as (n, H6).
	    assert (H7 : n > 0).
	   destruct n.
	    simpl in H6.
	      elim (AntisymLSlt C A C (BetweenDistinctCA _ _ _ H4) H6).
	      rewrite NullDist; apply (NullLSlt C A (BetweenDistinctCA _ _ _ H4)).
	    auto with arith.
	   destruct (StrongGraduation C I H5 n) as (J, (H8, (H9, H10))).
	     destruct (StrongGraduation C E (ParallelogrammDistinctAC _ _ _ _ H1) n)
	      as (F, (H11, (H12, H13))).
	     assert (H14 : Between C A J).
	    apply LSltBetween.
	     apply (BetweenDistinctCA _ _ _ H4).
	     assert (H14 := BetweenSymHalfLine _ _ _ H4);
	      apply (HalfLineSym C J A (H10 H7)).
	       canonize.
	     rewrite H9; trivial.
	    exists F; split.
	     apply CollinearACB; apply (HalfLineCollinear _ _ _ H11).
	     destruct (ExistsDParallelogramm B A J) as (K, H15).
	      canonize.
	        apply ClockwiseCAB; apply H19.
	        unfold Parallelogramm in *; intuition; autoClockwise.
	      apply (HalfLineParallel _ _ _ _ F H15).
	        apply BetweenSymHalfLine; apply (SupplementaryRec J F C K).
	       apply ClockwiseCAB; apply (ClockwiseBetweenMBC J C F A).
	        apply BetweenSym; trivial.
	        apply ClockwiseCAB; apply (HalfLineSym C F E (H13 H7) H11).
	          canonize; apply ClockwiseCAB; apply (BetweenClockwiseMBC D A C E).
	         apply ClockwiseBCA;
	          apply
	           (ParallelogrammClockwiseBCD B C D A
	              (ParallelogrammPermut _ _ _ _ H)).
	         canonize.
	       apply (ClockwiseBetweenMBC C J K A H14).
	         apply (ParallelogrammClockwiseBCD _ _ _ _ H15).
	      assert (H16 : Clockwise C E I).
	        apply ClockwiseBCA; apply (BetweenClockwiseMBC A C E I).
	         apply ClockwiseBCA; apply (BetweenClockwiseMBC D A C E).
	          apply ClockwiseBCA; apply (ParallelogrammClockwiseBCD B C D A).
	            exact (ParallelogrammPermut _ _ _ _ H).
	          trivial.
	         trivial.
	        destruct
	         (EmbeddedSimilarTriangles C E I n H16 H7 F J
	            (HalfLineSym _ _ _ (H13 H7) H11) (HalfLineSym _ _ _ (H10 H7) H8)
	            H12 H9).
	          rewrite (AngleSym J F C).
	         rewrite <- H18.
	           rewrite <- (BetweenAngleB J A K C).
	          assert
	           (H19 :=
	            ParallelogrammCongruentTrianglesAC _ _ _ _
	              (ParallelogrammPermut _ _ _ _ H15)).
	            rewrite (CongruentStrictTrianglesB _ _ _ _ _ _ H19).
	            rewrite (ExternParallelogramm K B A J C).
	           rewrite
	            (CongruentStrictTrianglesA _ _ _ _ _ _
	               (ParallelogrammCongruentTrianglesAC _ _ _ _ H))
	            .
	             rewrite (AngleSym C).
	            rewrite <- (TwoEmbeddedSymTriangles A C D I E).
	             unfold Supplementary in |- *; exists I; exists C; exists E;
	              exists A; intuition.
	              autoDistinct.
	              exact (BetweenSym _ _ _ H4).
	              apply AngleSym; autoDistinct.
	             apply ClockwiseCAB;
	              exact
	               (ParallelogrammClockwiseBCD _ _ _ _
	                  (ParallelogrammPermut _ _ _ _ H)).
	             trivial.
	             exact (BetweenSym _ _ _ H0).
	             apply sym_eq; rewrite (CongruentItself D A C E C).
	              rewrite (ExternOppParallelogramm _ _ _ _ _ H1 H0).
	                apply CongruentItself.
	               exact (ParallelogrammDistinctCD _ _ _ _ H1).
	               exact (BetweenDistinctBC _ _ _ H0).
	               destruct (ExclusiveCollinear E G I).
	                exact (ParallelogrammDistinctCD _ _ _ _ H1).
	                autoDistinct.
	                trivial.
	                trivial.
	                assert (H21 := EquiOrientedRev _ _ _ H20).
	                  clear H0 H2 H3 H4 H8 H11 H14 H20; generalizeChangeSide.
	                  elim
	                   (ClockwiseNotClockwise _ _ _
	                      (ParallelogrammClockwiseBCD _ _ _ _
	                         (ParallelogrammPermut _ _ _ _ H1))).
	                  apply H4.
	                 exact (ParallelogrammDistinctCD _ _ _ _ H1).
	                 autoClockwise.
	               canonize.
	              apply sym_not_eq; exact (BetweenDistinctCA _ _ _ H0).
	              apply sym_not_eq; exact (ParallelogrammDistinctAB _ _ _ _ H1).
	              apply HalfLineSym.
	               autoClockwise.
	               exact (BetweenHalfLine _ _ _ H0).
	              canonize.
	            exact (ParallelogrammDistinctCD _ _ _ _ H).
	            exact (BetweenDistinctAB _ _ _ H14).
	           do 3 apply ParallelogrammPermut; exact H15.
	           exact (BetweenSym _ _ _ H14).
	          exact (ParallelogrammDistinctCD _ _ _ _ H15).
	          exact (BetweenSym _ _ _ H14).
	         assert (H19 : Clockwise C F J).
	          clear H0 H3 H4 H14; generalizeChange.
	            apply H11; apply ClockwiseBCA.
	            apply H21; autoClockwise.
	          autoDistinct.
	         apply sym_not_eq; auto.
Qed.

Lemma ExistsClockwiseParallelogrammSym : forall A B C D E : Point,
	Parallelogramm A B C D ->
	Between A E C ->
	exists F : Point, Collinear D E F /\ Clockwise B A F.
Proof.
	intros.
	assert (Hacd : Clockwise A C D).
	 unfold Parallelogramm in *; intuition.
	 destruct (ExistsDParallelogramm E C D) as (G, H1).
	  exact (BetweenClockwiseMBC A C D E Hacd H0).
	  assert (Hcge : Clockwise C G E).
	   exact (ParallelogrammClockwiseBDA _ _ _ _ H1).
	   assert (Hedg : Clockwise E D G).
	    unfold Parallelogramm in *; intuition.
	    destruct (PaschABC A C D E G Hacd H0) as [(I, (H3, H4))| (I, (H3, H4))].
	     apply ClockwiseNotCollinear; assert (H2 := EquiOrientedRev _ _ _ H0);
	      canonize.
	       apply H2; autoClockwise.
	     intro; elim (ClockwiseNotCollinear _ _ _ Hcge); autoCollinear.
	     intro; elim (ClockwiseNotCollinear _ _ _ Hedg); autoCollinear.
	     assert (Hdie : Clockwise D I E).
	      apply (BetweenClockwiseAMC D A E I).
	       apply ClockwiseCAB; apply (BetweenClockwiseAMC A C D E Hacd H0).
	       exact (BetweenSym _ _ _ H4).
	      assert (H5 := sym_not_eq (BetweenDistinctBC _ _ _ H4)).
	        destruct (Archimedian D I A H5) as (n, H6).
	        assert (H7 : n > 0).
	       destruct n.
	        simpl in H6.
	          elim (AntisymLSlt D A D (BetweenDistinctCA _ _ _ H4) H6).
	          rewrite NullDist; apply (NullLSlt D A (BetweenDistinctCA _ _ _ H4)).
	        auto with arith.
	       destruct (StrongGraduation D I H5 n) as (J, (H8, (H9, H10))).
	         destruct
	          (StrongGraduation D E
	             (sym_not_eq (ParallelogrammDistinctAC _ _ _ _ H1)) n)
	          as (F, (H11, (H12, H13))).
	         assert (H14 : Between D A J).
	        apply LSltBetween.
	         apply (BetweenDistinctCA _ _ _ H4).
	         assert (H14 := BetweenSymHalfLine _ _ _ H4);
	          apply (HalfLineSym D J A (H10 H7)).
	           canonize.
	         rewrite H9; trivial.
	        exists F; split.
	         apply CollinearACB; apply (HalfLineCollinear _ _ _ H11).
	         destruct (ExistsDParallelogramm B A J) as (K, H15).
	          canonize.
	            apply ClockwiseCAB; apply H18.
	            apply (ParallelogrammClockwiseBCD C D A B);
	             do 2 apply ParallelogrammPermut; trivial.
	          apply (ParallelHalfLine _ _ _ _ F H15).
	            apply (AngleBHalfLine J K D F).
	           apply ClockwiseBCA; apply (ClockwiseBetweenMBC D J K A H14).
	             exact (ParallelogrammClockwiseBCD _ _ _ _ H15).
	           clear H0 H3 H4 H14; generalizeChange.
	             apply ClockwiseCAB; apply H3.
	             apply ClockwiseCAB; apply (H13 E Hdie).
	           assert (H16 : Angle K J D = Angle B A D).
	            rewrite (CongruentItself J K D K A).
	             rewrite (CongruentStrictTrianglesB A J K K B A).
	              apply (ExternParallelogramm K B A J D).
	               do 3 apply ParallelogrammPermut; exact H15.
	               exact (BetweenSym _ _ _ H14).
	              apply ParallelogrammCongruentTrianglesAC.
	                exact (ParallelogrammPermut _ _ _ _ H15).
	             exact (ParallelogrammDistinctCD _ _ _ _ H15).
	             exact (BetweenDistinctCA _ _ _ H14).
	             canonize.
	             apply HalfLineSym.
	              exact (sym_not_eq (BetweenDistinctBC _ _ _ H14)).
	              exact (BetweenSymHalfLine _ _ _ H14).
	            rewrite H16.
	              rewrite (Supplement A J B D I A E D).
	             rewrite (AngleSym I).
	              rewrite (AngleSym J).
	               destruct (EmbeddedSimilarTriangles D I E n Hdie H7 J F).
	                exact (HalfLineSym _ _ _ (H10 H7) H8).
	                exact (HalfLineSym _ _ _ (H13 H7) H11).
	                trivial.
	                trivial.
	                trivial.
	               apply (ClockwiseDistinctBC D J F).
	                 clear H0 H3 H4 H14; generalizeChange.
	                 apply ClockwiseBCA; apply H3.
	                 apply ClockwiseCAB; apply (H13 E Hdie).
	               exact (BetweenDistinctCA _ _ _ H14).
	              autoDistinct.
	              autoDistinct.
	             exact (ParallelogrammDistinctAB _ _ _ _ H).
	             autoDistinct.
	             exact (BetweenSym _ _ _ H14).
	             trivial.
	             rewrite (AngleSym A).
	              rewrite <- (ExternOppParallelogramm C D A B J).
	               rewrite (AngleSym D).
	                apply sym_eq; apply TwoEmbeddedTriangles.
	                 trivial.
	                 trivial.
	                 trivial.
	                 assert (H17 := ParallelogrammPermut _ _ _ _ H1).
	                   rewrite <- (BetweenAngleB C E D A).
	                  rewrite
	                   (CongruentStrictTrianglesB _ _ _ _ _ _
	                      (ParallelogrammCongruentTrianglesAC _ _ _ _ H1))
	                   .
	                    rewrite (ExternParallelogramm D G E C A).
	                   apply CongruentItself.
	                    apply sym_not_eq; exact (BetweenDistinctAB _ _ _ H0).
	                    autoDistinct.
	                    canonize.
	                    destruct (ExclusiveCollinear E I G).
	                     autoDistinct.
	                     autoDistinct.
	                     autoCollinear.
	                     trivial.
	                     elim (ClockwiseNotClockwise G E D).
	                      autoClockwise.
	                      assert (H18 := BetweenSym _ _ _ H2); canonize.
	                        apply H25; autoClockwise.
	                   apply ParallelogrammPermut; trivial.
	                   exact (BetweenSym _ _ _ H0).
	                  autoDistinct.
	                  exact (BetweenSym _ _ _ H0).
	                autoDistinct.
	                autoDistinct.
	               do 2 apply ParallelogrammPermut; trivial.
	               trivial.
	              exact (BetweenDistinctBC _ _ _ H14).
	              exact (ParallelogrammDistinctAB _ _ _ _ H).
	     elim (BetweenNotClockwiseABC _ _ _ (BetweenSym _ _ _ H4)).
	       apply ClockwiseBCA; destruct (CollinearHalfLine _ _ _ H3).
	      apply (HalfLineParallel C D G E I).
	       apply ParallelogrammPermut; trivial.
	       trivial.
	      apply (ParallelHalfLine C D G E I).
	       apply ParallelogrammPermut; trivial.
	       trivial.
Qed.

Lemma SecantParallelogrammSecant : forall A B : Point, forall F F' : Figure, forall D : Line F, forall D' : Line F',
	Parallelogramm (LineA F D) (LineB F D) A B ->
	F' A ->
	~F' B ->
	SecantLines F F' D D'.
Proof.
	intros; destruct (InOrOutLine (LineA F D) F' D').
	 apply (TwoPointsSecantLines A (LineA F D)).
	  unfold Parallelogramm in *; intuition.
	  apply NotClockwiseABA.
	  trivial.
	  trivial.
	 destruct
	  (CentralSymetPoint B A (sym_not_eq (ParallelogrammDistinctCD _ _ _ _ H)))
	  as (C, (H3, H4)).
	   destruct (Apart (LineA F' D') (LineB F' D') A (LineH F' D')).
	  destruct (PaschABC C B (LineA F D) A (LineA F' D'))
	   as [(E, (H6, H7))| (E, (H6, H7))].
	   apply (ClockwiseBetweenMBC C B (LineA F D) A).
	    apply BetweenSym; trivial.
	    apply ClockwiseBCA; unfold Parallelogramm in *; intuition.
	   apply BetweenSym; trivial.
	   intro; elim H1; apply (InFLine F' D').
		     apply (CollinearTrans (LineA F' D') A (LineB F' D') B H5).
	    apply CollinearACB; apply FLineIn; trivial.
	    apply CollinearCAB;
	     apply (CollinearTrans A C B (LineA F' D') (BetweenDistinctBC _ _ _ H4)).
	     apply CollinearBCA; apply BetweenCollinear; trivial.
	     autoCollinear.
	   intro; elim H1; apply (InFLine F' D').
	     apply (CollinearTrans (LineA F' D') A (LineB F' D') B H5).
	    apply CollinearACB; apply FLineIn; trivial.
	    autoCollinear.
	   intro; elim H2; apply (InFLine F' D').
	     apply (CollinearTrans (LineA F' D') A (LineB F' D') (LineA F D) H5).
	    apply CollinearACB; apply FLineIn; trivial.
	    autoCollinear.
	   destruct (ExistsClockwiseParallelogrammSym (LineA F D) (LineB F D) C A E)
	    as (G, (H8, H9)).
	    apply (ParallelogrammSym (LineA F D) (LineB F D) A B C H H3 H4).
	    apply BetweenSym; trivial.
	    apply (TwoPointsSecantLines A G).
	     unfold Parallelogramm in *; intuition.
	     apply ClockwiseNotClockwise; trivial.
	     trivial.
	     apply (InFLine F' D').
	       apply (CollinearTrans (LineA F' D') A (LineB F' D') G H5).
	      apply CollinearACB; apply FLineIn; trivial.
	      apply CollinearBAC; apply (CollinearTrans A E).
	       intro; subst; elim (CollinearNotClockwiseABC (LineA F D) C E).
	        apply CollinearCAB; apply BetweenCollinear; trivial.
	        assert (H10 := EquiOrientedRev _ _ _ (BetweenSym _ _ _ H4)).
	          apply ClockwiseCAB; unfold Parallelogramm in *; intuition; canonize.
	          apply H10; autoClockwise.
	       autoCollinear.
	       trivial.
	   destruct (ExistsClockwiseParallelogramm _ _ _ _ E H H7) as (G, (H8, H9)).
	     apply (TwoPointsSecantLines A G).
	    unfold Parallelogramm in *; intuition.
	    apply ClockwiseNotClockwise; trivial.
	    trivial.
	    apply (InFLine F' D').
	      apply (CollinearTrans (LineA F' D') A (LineB F' D') G H5).
	     apply CollinearACB; apply FLineIn; trivial.
	     apply CollinearBAC; apply (CollinearTrans A E).
	      intro; subst; elim (CollinearNotClockwiseABC (LineA F D) E B).
	       apply CollinearCBA; apply BetweenCollinear; trivial.
	       unfold Parallelogramm in *; intuition.
	      autoCollinear.
	      trivial.
	  destruct (PaschABC C B (LineA F D) A (LineB F' D'))
	   as [(E, (H6, H7))| (E, (H6, H7))].
	   apply (ClockwiseBetweenMBC C B (LineA F D) A).
	    apply BetweenSym; trivial.
	    apply ClockwiseBCA; unfold Parallelogramm in *; intuition.
	   apply BetweenSym; trivial.
	   intro; elim H1; apply (InFLine F' D').
	     apply CollinearBAC;
	      apply (CollinearTrans (LineB F' D') A (LineA F' D') B H5).
	    apply CollinearBCA; apply FLineIn; trivial.
	    apply CollinearCAB;
	     apply (CollinearTrans A C B (LineB F' D') (BetweenDistinctBC _ _ _ H4)).
	     apply CollinearBCA; apply BetweenCollinear; trivial.
	     autoCollinear.
	   intro; elim H1; apply (InFLine F' D').
	     apply CollinearBAC;
	      apply (CollinearTrans (LineB F' D') A (LineA F' D') B H5).
	    apply CollinearBCA; apply FLineIn; trivial.
	    autoCollinear.
	   intro; elim H2; apply (InFLine F' D').
	     apply CollinearBAC;
	      apply (CollinearTrans (LineB F' D') A (LineA F' D') (LineA F D) H5).
	    apply CollinearBCA; apply FLineIn; trivial.
	    autoCollinear.
	   destruct (ExistsClockwiseParallelogrammSym (LineA F D) (LineB F D) C A E)
	    as (G, (H8, H9)).
	    apply (ParallelogrammSym (LineA F D) (LineB F D) A B C H H3 H4).
	    apply BetweenSym; trivial.
	    apply (TwoPointsSecantLines A G).
	     unfold Parallelogramm in *; intuition.
	     apply ClockwiseNotClockwise; trivial.
	     trivial.
	     apply (InFLine F' D').
	       apply CollinearBAC;
	        apply (CollinearTrans (LineB F' D') A (LineA F' D') G H5).
	      apply CollinearBCA; apply FLineIn; trivial.
	      apply CollinearBAC; apply (CollinearTrans A E).
	       intro; subst; elim (CollinearNotClockwiseABC (LineA F D) C E).
	        apply CollinearCAB; apply BetweenCollinear; trivial.
	        assert (H10 := EquiOrientedRev _ _ _ (BetweenSym _ _ _ H4)).
	          apply ClockwiseCAB; unfold Parallelogramm in *; intuition; canonize.
	          apply H10; autoClockwise.
	       autoCollinear.
	       trivial.
	   destruct (ExistsClockwiseParallelogramm _ _ _ _ E H H7) as (G, (H8, H9)).
	     apply (TwoPointsSecantLines A G).
	    unfold Parallelogramm in *; intuition.
	    apply ClockwiseNotClockwise; trivial.
	    trivial.
	    apply (InFLine F' D').
	      apply CollinearBAC;
	       apply (CollinearTrans (LineB F' D') A (LineA F' D') G H5).
	     apply CollinearBCA; apply FLineIn; trivial.
	     apply CollinearBAC; apply (CollinearTrans A E).
	      intro; subst; elim (CollinearNotClockwiseABC (LineA F D) E B).
	       apply CollinearCBA; apply BetweenCollinear; trivial.
	       unfold Parallelogramm in *; intuition.
	      autoCollinear.
	      trivial.
Qed.

Lemma ParallelogrammSuperimposed : forall A B C E : Point, forall F : Figure, forall D : Line F,
	Parallelogramm A B C E ->
	EquiDirected A B (LineA F D) (LineB F D) ->
	F C ->
	Superimposed F (Collinear C E).
Proof.
	intros.
	destruct (Apart (LineA F D) (LineB F D) C (LineH F D)).
	 decompose [or] (ThreeCases (LineA F D) C E).
	  elim
	   (SecantParallelogrammSecant C E (Collinear A B) F
	      (Ruler A B (ParallelogrammDistinctAB _ _ _ _ H)) D H H1).
	   intro; elim (ClockwiseNotCollinear _ _ _ H3).
	     apply
	      (CollinearTrans (LineA F D) (LineB F D) C E (LineH F D)
	         (FLineIn F D C H1) (FLineIn F D E H4)).
	   exact H0.
	  elim
	   (SecantParallelogrammSecant C E (Collinear A B) F
	      (Ruler A B (ParallelogrammDistinctAB _ _ _ _ H)) D H H1).
	   intro; elim (ClockwiseNotCollinear _ _ _ H4); apply CollinearBAC.
	     apply
	      (CollinearTrans (LineA F D) (LineB F D) C E (LineH F D)
	         (FLineIn F D C H1) (FLineIn F D E H3)).
	   exact H0.
	  apply LineAB; auto.
	   apply (ParallelogrammDistinctCD _ _ _ _ H).
	   apply (InFLine F D E);
	    apply
	     (CollinearTrans (LineA F D) C (LineB F D) E H2
	        (CollinearACB _ _ _ (FLineIn F D C H1)) H4).
	 decompose [or] (ThreeCases (LineB F D) C E).
	  elim
	   (SecantParallelogrammSecant C E (Collinear A B) F
	      (Ruler A B (ParallelogrammDistinctAB _ _ _ _ H)) D H H1).
	   intro; elim (ClockwiseNotCollinear _ _ _ H3).
	     apply
	      (CollinearTrans (LineB F D) (LineA F D) C E (sym_not_eq (LineH F D))
	         (CollinearBAC _ _ _ (FLineIn F D C H1))
	         (CollinearBAC _ _ _ (FLineIn F D E H4))).
	   exact H0.
	  elim
	   (SecantParallelogrammSecant C E (Collinear A B) F
	      (Ruler A B (ParallelogrammDistinctAB _ _ _ _ H)) D H H1).
	   intro; elim (ClockwiseNotCollinear _ _ _ H4); apply CollinearBAC.
	     apply
	      (CollinearTrans (LineB F D) (LineA F D) C E (sym_not_eq (LineH F D))
	         (CollinearBAC _ _ _ (FLineIn F D C H1))
	         (CollinearBAC _ _ _ (FLineIn F D E H3))).
	   exact H0.
	  apply LineAB; auto.
	   apply (ParallelogrammDistinctCD _ _ _ _ H).
	   apply (InFLine F D E); apply CollinearBAC.
	     apply
	      (CollinearTrans (LineB F D) C (LineA F D) E H2
	         (CollinearBCA _ _ _ (FLineIn F D C H1)) H4).
Qed.

End DISTINCT_PARALLEL.


Require Export TcfgLoop CFGloopcutting.
Require Import Lia.

Section cfg.

  Context `(C : redCFG).

  Notation "pi -t> qj" := (tcfg_edge pi qj) (at level 50).
  Fixpoint zero_tag n
    := match n with
       | 0 => nil
       | S n => 0 :: zero_tag n
       end.

  Lemma tcfg_zero_reach q
    : exists t, TPath (root,start_tag) (q,zero_tag (depth q)) t.
  Proof.
    specialize (a_reachability q) as Hreach.
    destructH.
    revert q Hreach.
    induction π; intros.
    - inv Hreach.
    - destruct π.
      + path_simpl' Hreach.
        rewrite depth_root. cbn.
        eexists;econstructor;eauto.
      + inv_path Hreach.
        eapply a_edge_incl in H0 as H0'.
        specialize (IHπ e).
        exploit IHπ.
        destructH.
        exists ((q, zero_tag (depth q)) :: t).
        destruct (edge_Edge H0');econstructor;eauto.
        * copy b b'.
          destruct b'. rewrite H1 at 2.
          eapply tcfg_basic_edge;eauto.
        * exfalso. destruct b. contradiction.
        * copy e0 e0'.
          eapply depth_entry in e0. rewrite <- e0.
          replace (zero_tag (S (depth e))) with (0 :: zero_tag (depth e)) by (cbn;auto).
          eapply tcfg_entry_edge;eauto.
        * copy e0 e1.
          eapply depth_exit in e0.
          rewrite e0.
          replace (zero_tag (S (depth q))) with (0 :: zero_tag (depth q)) by (cbn;auto).
          eapply tcfg_exit_edge;eauto.
  Qed.

  (* this is true but way more complicate than what I need
  Lemma tcfg_reach_iter q i j
        (Hlen : | i | = depth q)
        (Htagle : i ⊴ j)
    : exists t, TPath (q,i) (q,j) t.
   *)

  Lemma tcfg_path_acyclic_deq p q π i j
        (Hpath : APath p q π)
        (Hdeq : deq_loop q p)
        (Hlenp : | i | = depth p)
        (Hj : j = zero_tag (depth q - depth p) ++ i)
    : exists t, TPath (p,i) (q,j) t.
  Proof.
    revert q j Hpath Hj Hdeq.
    induction π;intros;[|destruct π];inv_path Hpath.
      - replace (depth a - depth a) with 0 by lia. cbn.
        eexists;econstructor.
      - eapply a_edge_incl in H0 as Hedge.
        remember (zero_tag (depth e - depth p) ++ i) as j.
        specialize (IHπ e j).
        do 2 exploit' IHπ.
        destruct (edge_Edge Hedge).
        + copy b b'.
          destruct b.
          exploit IHπ.
          * eapply eq_loop1;eauto. symmetry;eauto.
          * destructH. exists ((a,j) :: t). rewrite H1 in Heqj. subst j. econstructor;eauto.
            eapply tcfg_basic_edge;eauto.
        + exfalso.
          destruct b. contradiction.
        + decide (deq_loop p a).
          * exfalso.
            assert (loop_contains a p) as Hloop.
            { eapply deq_loop_head_loop_contains;eauto. destruct e0. auto. }
            eapply loop_reachs_member in Hloop. destruct Hloop as [π' Hloop].
            eapply path_app' in H;eauto. cbn in H.
            eapply a_edge_acyclic;eauto.
          * exploit IHπ.
            -- intros h Hh. eapply deq_loop_entry_or in e0.
               ++ destruct e0;[eauto|]. subst a. exfalso. eapply loop_contains_deq_loop in Hh. contradiction.
               ++ eapply Hdeq;eauto.
            -- eapply depth_entry in e0 as Hdep. rewrite <-Hdep.
               assert (depth p < depth a) as Hlt.
               {
                 copy Hdeq Hdeq'.
                 eapply deq_loop_depth in Hdeq. eapply le_lt_or_eq in Hdeq. destruct Hdeq;[auto|].
                 exfalso. eapply n. eapply deq_loop_depth_leq;auto. rewrite H1. reflexivity.
               }
               replace (S (depth e) - depth p) with (S (depth e - depth p)) by lia.
               cbn.
               destructH.
               exists ((a,0 :: j) :: t).
               subst j. econstructor;eauto.
               eapply tcfg_entry_edge;eauto.
        + exploit IHπ.
          { destruct e0. transitivity a;eauto. eapply deq_loop_exited;eauto. }
          eapply depth_exit in e0 as Hdep. rewrite Hdep in Heqj.
          rewrite Nat.sub_succ_l in Heqj. 2: eapply deq_loop_depth;assumption.
          cbn in Heqj.
          destructH.
          exists ((a,tl j) :: t).
          subst j. cbn.
          econstructor;eauto.
          eapply tcfg_exit_edge;eauto.
  Qed.

  Lemma tcfg_path_acyclic p q π i
        (Hpath : APath p q π)
        (Heq : eq_loop p q)
        (Hlen : | i | = depth p)
    : exists t, TPath (p,i) (q,i) t.
  Proof.
    eapply tcfg_path_acyclic_deq;eauto.
    - destruct Heq;auto.
    - rewrite Heq. replace (depth q - depth q) with 0 by lia. cbn. reflexivity.
  Qed.

  Lemma tcfg_reachability q j
        (Hlen : | j | = depth q)
    : exists t, TPath (root,start_tag) (q,j) t.
  Proof.
    revert dependent q.
    induction j;intros.
    - cbn in Hlen.
      cbn. fold (zero_tag 0). rewrite Hlen.
      eapply tcfg_zero_reach.
    - specialize (get_innermost_loop_spec q) as Hinner.
      destruct (get_innermost_loop q).
      2: { exfalso. eapply depth_zero_iff in Hinner. cbn in Hlen. lia. }
      induction a.
      + specialize (a_reachability e) as Hreach.
        destructH.
        destruct π. 1: inv Hreach.
        destruct π.
        * path_simpl' Hreach. eapply innermost_eq_loop in Hinner. rewrite <-Hinner in Hlen.
          rewrite depth_root in Hlen. cbn in Hlen. lia.
        * inv_path Hreach. specialize (IHj e1).
          eapply loop_head_acyclic_entry in H0 as Hentry;
              [|destruct Hinner;eauto using loop_contains_loop_head].
          exploit IHj.
          {
            eapply depth_entry in Hentry. eapply innermost_eq_loop in Hinner. rewrite <-Hinner in Hlen.
            cbn in Hlen.
            lia.
          }
          destructH. copy Hinner Hinner'.
          destruct Hinner. eapply loop_reachs_member in H1.
          destruct H1.
          eapply tcfg_path_acyclic in H1. 2: eapply innermost_eq_loop;auto.
          2: eapply innermost_eq_loop in Hinner';rewrite Hinner';eassumption.
          destructH.
          exists (t0 ++ t).
          eapply path_app;eauto.
          eapply tcfg_entry_edge;eauto.
      + exploit IHa. destructH.
        copy Hinner Hinner'.
        eapply member_reachs_innermost_latch_acyclic in Hinner' as H.
        destruct Hinner'. copy H0 H'.
        destructH.
        eapply tcfg_path_acyclic with (i := a :: j) in H3.
        2: { eapply back_edge_eq_loop in H2. rewrite H2. symmetry. eapply innermost_eq_loop;eauto. }
        2: { cbn in Hlen. cbn. eassumption. }
        destructH.
        eapply loop_reachs_member in H'.
        destruct H'.
        eapply tcfg_path_acyclic in H.
        2: { eapply innermost_eq_loop;auto. }
        2: { eapply innermost_eq_loop in Hinner. rewrite Hinner. eassumption. }
        destructH.
        exists (t1 ++ (t0 ++ tl t)).
        eapply path_app;eauto.
        * eapply path_app';eauto.
        * eapply tcfg_back_edge;auto.
  Qed.

  Lemma tag_depth_unroot p q i j t
        (Hpath : TPath (q,j) (p,i) t)
        (Hlen : |j| = depth q)
    : |i| = depth p.
  Proof.
    eapply tcfg_reachability in Hlen.
    destructH.
    eapply path_app' in Hpath;eauto.
    eapply tag_depth';eauto.
  Qed.

  Lemma tag_depth_unroot2 p q i j t
        (Hpath : TPath (p,i) (q,j) t)
        (Hdep : | j | = depth q)
    : | i | = depth p.
  Proof.
    revert q j Hdep Hpath.
    induction t;intros;inv_path Hpath.
    - assumption.
    - destruct x. specialize (IHt e t0). exploit IHt.
      + eapply tcfg_edge_depth_iff;eauto.
      + assumption.
  Qed.

  Lemma tag_depth_unroot_elem p q i j t x k
        (Hpath : TPath (q,j) (p,i) t)
        (Hlen : |j| = depth q)
        (Hin : (x,k) ∈ t)
    : |k| = depth x.
  Proof.
    eapply path_to_elem in Hin;eauto.
    destructH.
    eapply tag_depth_unroot;eauto.
  Qed.

  Lemma tag_depth_unroot_elem2 p q i j t x k
        (Hpath : TPath (q,j) (p,i) t)
        (Hlen : |i| = depth p)
        (Hin : (x,k) ∈ t)
    : |k| = depth x.
  Proof.
    eapply path_from_elem in Hin;eauto.
    destructH.
    eapply tag_depth_unroot2;eauto.
  Qed.

  Lemma tcfg_enroot p q i j t
        (Hpath : TPath (p,i) (q,j) t)
        (Hlen  : | i | = depth p)
    : exists t', TPath (root,start_tag) (q,j) (t ++ t').
  Proof.
    eapply tcfg_reachability in Hlen.
    destructH.
    eexists.
    eapply path_app';eauto.
  Qed.

End cfg.


Require Import init.

Require Import rat.
Require Import set.

Require Export dedekind_real_base.

Unset Keyed Unification.

(* begin hide *)
Open Scope set_scope.
(* end hide *)
Global Instance real_order : Order real := {
    le a b := [a|] ⊆ [b|]
}.

(* begin hide *)
Lemma real_le_connex_ : ∀ a b, {a ≤ b} + {b ≤ a}.
Proof.
    intros [a a_cut] [b b_cut].
    unfold le; cbn.
    classic_case (a ⊆ b) as [ab|nab]; try (left; exact ab).
    right.
    unfold subset in nab; cbn in nab.
    rewrite not_all in nab.
    destruct nab as [u nab].
    rewrite not_impl in nab.
    destruct nab as [au nbu].
    intros l bl.
    apply (land (rand (rand a_cut)) l u au).
    apply (dedekind_lt b b_cut l u bl nbu).
Qed.
Global Instance real_le_connex : Connex le := {
    connex := real_le_connex_
}.

Lemma real_le_antisymmetric : ∀ a b, a ≤ b → b ≤ a → a = b.
Proof.
    intros [a a_cut] [b b_cut].
    unfold le; cbn.
    intros ab ba.
    apply set_type_eq; cbn.
    exact (antisym ab ba).
Qed.
Global Instance real_le_antisym : Antisymmetric le := {
    antisym := real_le_antisymmetric
}.

Lemma real_le_transitive : ∀ a b c, a ≤ b → b ≤ c → a ≤ c.
Proof.
    intros a b c.
    unfold le; cbn.
    apply trans.
Qed.
Global Instance real_le_trans : Transitive le := {
    trans := real_le_transitive;
}.

Lemma real_sup_complete_ : ∀ S : real → Prop, (∃ x, S x) →
    has_upper_bound le S → has_supremum le S.
Proof.
    intros S [[l l_cut] Sl] [[u u_cut] u_upper].
    pose (α a := ∃ x, S x ∧ [x|] a).
    assert (dedekind_cut α) as α_cut.
    {
        split.
        2: split.
        3: split.
        -   intro contr.
            pose proof (land u_cut) as u'_ex.
            apply all_neq in u'_ex as [u' u'u].
            assert (α u') as αu' by (rewrite contr; exact true).
            destruct αu' as [x [Sx xu']].
            apply u_upper in Sx.
            apply Sx in xu'.
            contradiction.
        -   apply empty_neq.
            unfold α.
            pose proof (land (rand l_cut)) as l'_ex.
            apply empty_neq in l'_ex.
            destruct l'_ex as [l' l'l].
            exists l', [l|l_cut].
            split; assumption.
        -   intros l' u' [[x x_cut] [Sx xu']] ltq.
            cbn in xu'.
            unfold α.
            exists [x|x_cut].
            split; try assumption.
            cbn.
            exact (land (rand (rand x_cut)) _ u' xu' ltq).
        -   intros l' [[x x_cut] [Sx xl']].
            cbn in xl'.
            pose proof (rand (rand (rand x_cut)) l' xl') as [u' [xu' ltq]].
            exists u'.
            split; try assumption.
            exists [x|x_cut].
            split; assumption.
    }
    exists [α|α_cut].
    split.
    -   intros [x x_cut] Sx a xa; cbn in *.
        exists [x|x_cut].
        split; assumption.
    -   intros [x x_cut] x_upper a [[y y_cut] [Sy ya]]; cbn in *.
        apply (x_upper [y|y_cut]); assumption.
Qed.
Global Instance real_sup_complete : SupremumComplete le := {
    sup_complete := real_sup_complete_
}.
(* end hide *)

Theorem rat_to_real_le : ∀ a b, rat_to_real a ≤ rat_to_real b ↔ a ≤ b.
Proof.
    intros a b; split; intro leq.
    -   unfold le in leq; cbn in leq.
        unfold rat_to_real_base in leq.
        classic_contradiction contr.
        rewrite nle_lt in contr.
        apply leq in contr.
        destruct contr; contradiction.
    -   intros x ax.
        cbn in *; unfold rat_to_real_base in *.
        exact (lt_le_trans ax leq).
Qed.

Theorem gt_rat_to_real_in : ∀ a b, rat_to_real a < b → [b|] a.
Proof.
    intros a [b b_cut] [leq neq]; cbn.
    classic_contradiction contr.
    apply neq.
    apply antisym; try exact leq.
    intros x bx; cbn in *.
    exact (dedekind_lt _ b_cut _ _ bx contr).
Qed.

Theorem real_lt_ex_between : ∀ a b, a < b → ∃ x, ¬[a|] x ∧ [b|] x.
Proof.
    intros a b ab.
    destruct ab as [leq neq].
    classic_contradiction contr.
    apply neq.
    apply antisym; try exact leq.
    intros x bx.
    rewrite not_ex in contr.
    specialize (contr x).
    rewrite not_and, not_not in contr.
    destruct contr as [ax|nbx].
    -   exact ax.
    -   contradiction.
Qed.
(* begin hide *)
Close Scope set_scope.
(* end hide *)


From Coq Require Import ZArith Lia.
From Coq Require Import Int63.
From Coq Require Bool.
From Coq Require Import CyclicAxioms.

From Vyper Require Import Arith2 UInt63 Nibble.

Definition uint64 := (bool * int)%type.
Definition t := uint64.

Local Open Scope Z_scope.

Definition Z_of_uint64 (a: uint64)
:= match a with
   | (false, n) => Int63.to_Z n
   | (true , n) => Int63.to_Z n + Int63.wB
   end.

Definition Z_of_uint64_lor (a: uint64)
:= match a with
   | (false, n) => Int63.to_Z n
   | (true , n) => Z.lor (Int63.to_Z n) Int63.wB
   end.

Lemma Z_of_uint64_lor_ok (a: uint64):
  Z_of_uint64_lor a = Z_of_uint64 a.
Proof.
unfold Z_of_uint64_lor.
destruct a as (b, n).
rewrite<- Arith2.Z_add_nocarry_lor. { trivial. }
apply Arith2.Z_land_pow2_small. { apply to_Z_bounded. }
apply Nat2Z.is_nonneg.
Qed.

Definition Z_of_uint64_lxor (a: uint64)
:= match a with
   | (false, n) => Int63.to_Z n
   | (true , n) => Z.lxor (Int63.to_Z n) Int63.wB
   end.

Lemma Z_of_uint64_lxor_ok (a: uint64):
  Z_of_uint64_lxor a = Z_of_uint64 a.
Proof.
unfold Z_of_uint64_lxor.
destruct a as (b, n).
rewrite<- Z.add_nocarry_lxor. { trivial. }
apply Arith2.Z_land_pow2_small. { apply to_Z_bounded. }
apply Nat2Z.is_nonneg.
Qed.

Lemma Z_of_uint64_lower (a: uint64):
  0 <= Z_of_uint64 a.
Proof.
destruct a as (hi, lo).
assert(B := Int63.to_Z_bounded lo).
destruct B as (L, H).
destruct hi; unfold Z_of_uint64; lia.
Qed.

Lemma Z_of_uint64_upper (a: uint64):
  Z_of_uint64 a < 2^64.
Proof.
destruct a as (hi, lo).
assert(B := Int63.to_Z_bounded lo).
destruct B as (_, H).
assert (E: Int63.wB = 2^63). { unfold Int63.wB. f_equal. }
destruct hi; unfold Z_of_uint64; lia.
Qed.

Definition Z_of_uint64' (a: uint64)
:= let (b, n) := a in
   Int63.to_Z n + (if b then 1 else 0) * Int63.wB.

Lemma Z_of_uint64_alt (a: uint64):
  Z_of_uint64' a = Z_of_uint64 a.
Proof.
unfold Z_of_uint64'. unfold Z_of_uint64.
destruct a as (b, n). destruct b; lia.
Qed.

Definition Z_of_uint64_lor' (a: uint64)
:= let (b, n) := a in
   Z.lor (Int63.to_Z n) ((if b then 1 else 0) * Int63.wB).

Lemma Z_of_uint64_lor'_ok (a: uint64):
  Z_of_uint64_lor' a = Z_of_uint64' a.
Proof.
unfold Z_of_uint64_lor'.
destruct a as (b, n).
rewrite<- Arith2.Z_add_nocarry_lor. { trivial. }
destruct b.
{
  rewrite Z.mul_1_l. apply Arith2.Z_land_pow2_small.
  { apply to_Z_bounded. } apply Nat2Z.is_nonneg.
}
rewrite Z.mul_0_l. rewrite Z.land_0_r. trivial.
Qed.

Definition uint64_of_Z (z: Z)
                        (lower: 0 <= z)
                        (upper: z < 2^64)
: uint64
:= (2^63 <=? z, Int63.of_Z z).

Lemma uint64_of_Z_of_uint64 (a: uint64):
  uint64_of_Z (Z_of_uint64 a) (Z_of_uint64_lower a) (Z_of_uint64_upper a) = a.
Proof.
assert (E: Int63.wB = 2^63). { unfold Int63.wB. f_equal. }
destruct a as (hi, lo).
assert(B := Int63.to_Z_bounded lo).
destruct hi; unfold Z_of_uint64; unfold uint64_of_Z.
{
  rewrite E. f_equal.
  { rewrite Z.leb_le. lia. }
  rewrite<- E. clear E.
  apply Int63.to_Z_inj. rewrite Int63.of_Z_spec.
  rewrite Z.add_comm.
  rewrite<- Zplus_mod_idemp_l.
  rewrite Z_mod_same_full.
  rewrite Z.add_0_l.
  remember (Int63.to_Z lo) as n. clear Heqn.
  exact (Z.mod_small _ _ B).
}
rewrite<- E.
f_equal. { rewrite Z.leb_gt. tauto. }
apply Int63.of_to_Z.
Qed.

Lemma Z_of_uint64_of_Z (z: Z)
                        (lower: 0 <= z)
                        (upper: z < 2^64):
  Z_of_uint64 (uint64_of_Z z lower upper) = z.
Proof.
assert (E: Int63.wB = 2^63). { unfold Int63.wB. f_equal. }
unfold Z_of_uint64. unfold uint64_of_Z.
remember (2 ^ 63 <=? z) as is_high.
rewrite Int63.of_Z_spec.
symmetry in Heqis_high.
destruct is_high.
{
  rewrite Z.leb_le in Heqis_high.
  rewrite E. clear E.
  remember (z - 2^63) as y.
  assert (YL: 0 <= y) by lia.
  assert (YU: y < 2^63) by lia.
  assert (R: z mod 2^63 = y mod 2^63).
  {
    subst.
    rewrite<- Zminus_mod_idemp_r.
    rewrite Z_mod_same_full.
    rewrite Z.sub_0_r.
    trivial.
  }
  rewrite R.
  rewrite (Z.mod_small _ _ (conj YL YU)).
  lia.
}
rewrite Z.leb_gt in Heqis_high.
apply Z.mod_small. tauto.
Qed.

Definition uint64_of_Z_mod (z: Z)
: uint64
:= (Z.testbit z 63, Int63.of_Z z).

Lemma uint64_mod_pos_bound (a: Z):
  0 <= a mod 2^64 < 2^64.
Proof.
apply Z.mod_pos_bound.
rewrite<- Z.ltb_lt.
trivial.
Qed.

Lemma uint64_of_Z_mod_ok (z: Z):
  uint64_of_Z_mod z = uint64_of_Z (z mod 2^64)
                                  (proj1 (uint64_mod_pos_bound z))
                                  (proj2 (uint64_mod_pos_bound z)).
Proof.
unfold uint64_of_Z. unfold uint64_of_Z_mod.
f_equal.
{
  rewrite<- (Z.mod_pow2_bits_low z 64 63) by now rewrite<- Z.ltb_lt.
  assert (B := uint64_mod_pos_bound z).
  remember (z mod 2 ^ 64) as x. clear Heqx.
  rewrite (Z.testbit_odd x 63).
  rewrite Z.shiftr_div_pow2 by now rewrite<- Z.leb_le.
  remember (2 ^ 63 <=? x) as f. symmetry in Heqf.
  destruct f.
  {
    rewrite Z.leb_le in Heqf.
    assert(L: 1 <= x / 2 ^ 63).
    {
      rewrite<- (Z.div_same (2^63)) by discriminate.
      apply Z.div_le_mono. { rewrite<- Z.ltb_lt. trivial. }
      assumption.
    }
    assert (U: x / 2^63 <= (2 ^ 64 - 1) / 2 ^ 63).
    {
      apply Z.div_le_mono. { rewrite<- Z.ltb_lt. trivial. }
      lia.
    }
    replace ((2 ^ 64 - 1) / 2 ^ 63) with 1 in U by trivial.
    assert (E: x / 2 ^ 63 = 1) by lia.
    now rewrite E.
  }
  rewrite (Logic2.b_false (Z.leb_le _ _)) in Heqf.
  apply Z.nle_gt in Heqf.
  replace (x / 2 ^ 63) with 0. 2:{ symmetry. apply Z.div_small. tauto. }
  trivial.
}
apply to_Z_inj.
repeat rewrite of_Z_spec.
apply Znumtheory.Zmod_div_mod; try rewrite<- Z.ltb_lt; trivial.
replace (2^64) with (2 * wB) by trivial.
apply Z.divide_factor_r.
Qed.

Lemma Z_of_uint64_of_Z_mod (z: Z):
  Z_of_uint64 (uint64_of_Z_mod z) = z mod 2^64.
Proof.
rewrite uint64_of_Z_mod_ok.
rewrite Z_of_uint64_of_Z.
trivial.
Qed.

Definition uint64_0: uint64 := (false, 0%int63).
Lemma uint64_0_ok:
  Z_of_uint64 uint64_0 = 0.
Proof. trivial. Qed.
Definition uint64_1: uint64 := (false, 1%int63).
Lemma uint64_1_ok:
  Z_of_uint64 uint64_1 = 1.
Proof. trivial. Qed.
Definition uint64_2: uint64 := (false, 2%int63).
Lemma uint64_2_ok:
  Z_of_uint64 uint64_2 = 2.
Proof. trivial. Qed.
Definition uint64_4: uint64 := (false, 4%int63).
Lemma uint64_4_ok:
  Z_of_uint64 uint64_4 = 4.
Proof. trivial. Qed.
Definition uint64_8: uint64 := (false, 8%int63).
Lemma uint64_8_ok:
  Z_of_uint64 uint64_8 = 8.
Proof. trivial. Qed.
Definition uint64_16: uint64 := (false, 16%int63).
Lemma uint64_16_ok:
  Z_of_uint64 uint64_16 = 16.
Proof. trivial. Qed.
Definition uint64_32: uint64 := (false, 32%int63).
Lemma uint64_32_ok:
  Z_of_uint64 uint64_32 = 32.
Proof. trivial. Qed.
Definition uint64_64: uint64 := (false, 64%int63).
Lemma uint64_64_ok:
  Z_of_uint64 uint64_64 = 64.
Proof. trivial. Qed.
Definition uint64_128: uint64 := (false, 128%int63).
Lemma uint64_128_ok:
  Z_of_uint64 uint64_128 = 128.
Proof. trivial. Qed.

Definition uint64_24: uint64 := (false, 24%int63).
Lemma uint64_24_ok:
  Z_of_uint64 uint64_24 = 24.
Proof. trivial. Qed.
Definition uint64_40: uint64 := (false, 40%int63).
Lemma uint64_40_ok:
  Z_of_uint64 uint64_40 = 40.
Proof. trivial. Qed.
Definition uint64_48: uint64 := (false, 48%int63).
Lemma uint64_48_ok:
  Z_of_uint64 uint64_48 = 48.
Proof. trivial. Qed.
Definition uint64_56: uint64 := (false, 56%int63).
Lemma uint64_56_ok:
  Z_of_uint64 uint64_56 = 56.
Proof. trivial. Qed.

Definition uint64_max_value: uint64 := (true, max_int).
Lemma uint64_max_value_ok:
  Z_of_uint64 uint64_max_value = 2^64 - 1.
Proof. trivial. Qed.

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

Definition add (a b: uint64)
: uint64
:= let (ha, la) := a in
   let (hb, lb) := b in
   let x := xorb ha hb in
   match Int63.addc la lb with
   | DoubleType.C0 c => (x, c)
   | DoubleType.C1 c => (negb x, c)
   end.

Ltac wB_up
:= repeat (rewrite (Z.add_comm _ Int63.wB)
        || rewrite (Z.add_comm _ (_ * Int63.wB)));
   repeat rewrite Z.add_assoc;
   repeat rewrite<- Z.mul_add_distr_r.

Lemma mod_wB (x: Z):
  (x * Int63.wB) mod 2 ^ 64 = if Z.odd x then Int63.wB else 0.
Proof.
remember (Z.odd x) as last_bit.
rewrite (Zdiv2_odd_eqn x). subst.
rewrite Z.mul_add_distr_r.
replace (2 * Z.div2 x) with (Z.div2 x * 2) by apply Z.mul_comm.
rewrite<- Z.mul_assoc.
replace (2 * Int63.wB) with (2 ^ 64)%Z by trivial.
rewrite Z.add_comm. rewrite Z.mod_add by discriminate.
now destruct (Z.odd x).
Qed.

Lemma add_ok (a b: uint64):
  Z_of_uint64 (add a b) = ((Z_of_uint64 a + Z_of_uint64 b) mod 2^64).
Proof.
assert (L := Z_of_uint64_lower (add a b)).
assert (U := Z_of_uint64_upper (add a b)).
repeat rewrite<- Z_of_uint64_alt in *.
rewrite<- (Z.mod_small (Z_of_uint64' (add a b)) (2 ^ 64)) by tauto.
unfold add. destruct a as (ha, la). destruct b as (hb, lb).
assert (R := Int63.addc_spec la lb).
cbn in L. cbn in U.
unfold DoubleType.interp_carry in R.
remember (Int63.addc la lb) as x. clear Heqx.
unfold Z_of_uint64'.
destruct x;
  [rewrite R | try rewrite Z.mul_1_l in R;
               replace (Int63.to_Z i) with (Int63.to_Z la + Int63.to_Z lb + (-1) * Int63.wB) by lia];
  wB_up; wB_up; repeat rewrite<- Z.add_assoc;
  apply Z_mod_add_r;
  destruct ha, hb; rewrite mod_wB; trivial.
Qed.

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

Definition shr_uint63 (a: uint64) (sh: uint63)
: uint64
:= if (sh =? 0)%int63
     then a
     else let (hi, lo) := a in
       (false, if hi
                 then (((1 << 62) >> (sh - 1)) lor (lo >> sh))%int63
                 else lsr lo sh).

Lemma shr_uint63_ok (a: uint64) (sh: uint63):
  Z_of_uint64 (shr_uint63 a sh) = Z.shiftr (Z_of_uint64 a) (Int63.to_Z sh).
Proof.
unfold shr_uint63.
remember ((sh =? 0)%int63) as sh0 eqn:Sh0. symmetry in Sh0. destruct sh0.
{ rewrite Int63.eqb_spec in Sh0. now subst. }
assert(BS := to_Z_bounded sh). remember (to_Z sh) as s.
assert(SPos: 0 < s).
{
  enough (s <> 0) by lia.
  intro H. subst.
  replace 0 with (to_Z 0) in H by trivial.
  apply to_Z_inj in H.
  apply eqb_spec in H.
  rewrite H in Sh0.
  discriminate.
}
destruct a as (hi, lo).
destruct hi; unfold Z_of_uint64.
2:{
  (* low case *)
  rewrite Int63.lsr_spec.
  rewrite Z.shiftr_div_pow2 by tauto.
  now subst.
}
(* high case *)
rewrite Int63.lor_spec'.
rewrite Int63.lsr_spec.
rewrite Int63.lsr_spec.
rewrite Int63.lsl_spec.
rewrite Int63.sub_spec.
replace (to_Z 1) with 1 by trivial.
replace (to_Z 62) with 62 by trivial.
rewrite<- Heqs.
clear Sh0 Heqs.
assert(BN := to_Z_bounded lo). remember (to_Z lo) as n. clear Heqn.
rewrite Z.mul_1_l. rewrite Z.shiftr_div_pow2 by tauto.
replace (2 ^ 62 mod wB) with (2 ^ 62) by trivial.
replace ((s - 1) mod wB) with (s - 1). 2:{ symmetry. apply Z.mod_small. lia. }
assert (CS: 64 <= s \/ s <= 63) by lia.
case CS; clear CS; intro CS.
{
  (* large shift, everything is 0 *)
  replace (n / 2 ^ s) with 0.
  2:{
    symmetry. apply Z.div_small.
    split. { tauto. }
    replace Int63.wB with (2 ^ 63) in * by trivial.
    apply (Z.lt_trans n (2^63) (2^s)). { tauto. }
    apply Z.pow_lt_mono_r; lia.
  }
  rewrite Z.lor_0_r.
  rewrite Z.div_small.
  2:{
    split. { lia. }
    apply Z.pow_lt_mono_r; lia.
  }
  rewrite Z.div_small. { trivial. }
  split. { lia. }
  apply (Z.lt_le_trans _ (2^64) (2^s)).
  { replace (2 ^ 64) with (wB + wB) by trivial. lia. }
  apply Z.pow_le_mono_r; lia.
}
replace (2 ^ 62 / 2 ^ (s - 1)) with (2 ^ 63 / 2 ^ s).
2:{
  replace (2 ^ 63) with (2 * (2 ^ 62)) by trivial.
  replace (2 ^ s) with ((2 ^ (1 + (s - 1)))) by now replace (1 + (s - 1)) with s by lia.
  rewrite Z.pow_add_r; try lia.
  rewrite Z.div_mul_cancel_l; try lia.
  apply Z.pow_nonzero; lia.
}
repeat rewrite<- Z.shiftr_div_pow2 by tauto.
rewrite<- Z.shiftr_lor.
f_equal.
rewrite<- Arith2.Z_add_nocarry_lor. { apply Z.add_comm. }
rewrite Z.land_comm.
apply Arith2.Z_land_pow2_small. { tauto. }
now rewrite<- Z.leb_le.
Qed.

Definition shr (a: uint64) (sh: uint64)
: uint64
:= match sh with
   | (false, sh63) => shr_uint63 a sh63
   | (true, _) => uint64_0
   end.

Lemma shr_ok (a: uint64) (sh: uint64):
  Z_of_uint64 (shr a sh) = Z.shiftr (Z_of_uint64 a) (Z_of_uint64 sh).
Proof.
destruct sh as (sh_hi, sh_lo).
destruct sh_hi.
2:{ (* low case *)
  replace (shr a (false, sh_lo)) with (shr_uint63 a sh_lo) by trivial.
  replace (Z_of_uint64 (false, sh_lo)) with (Int63.to_Z sh_lo) by trivial.
  apply shr_uint63_ok.
}
(* high case *)
match goal with |- ?lhs = ?rhs => replace lhs with 0 by trivial end.
symmetry.
rewrite Z.shiftr_div_pow2 by apply Z_of_uint64_lower.
apply Z.div_small.
split. { apply Z_of_uint64_lower. }
refine (Z.lt_trans _ _ _ (Z_of_uint64_upper a) _).
apply Z.pow_lt_mono_r. { easy. } { apply Z_of_uint64_lower. }
unfold Z_of_uint64.
assert (B := to_Z_bounded sh_lo).
unfold wB. remember (to_Z sh_lo) as x. clear Heqx.
unfold size. lia.
Qed.

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

Definition shl_uint63 (a: uint64) (sh: uint63)
: uint64
:= if (sh =? 0)%int63
     then a
     else let (hi, lo) := a in
       (get_digit lo (63 - sh), lsl lo sh).

Lemma shl_uint63_ok (a: uint64) (sh: uint63):
  Z_of_uint64 (shl_uint63 a sh) = (Z.shiftl (Z_of_uint64 a) (Int63.to_Z sh) mod 2^64)%Z.
Proof.
repeat rewrite<- Z_of_uint64_alt. repeat rewrite<- Z_of_uint64_lor'_ok.
unfold shl_uint63.
remember ((sh =? 0)%int63) as sh0 eqn:Sh0. symmetry in Sh0. destruct sh0.
{
  rewrite Int63.eqb_spec in Sh0. subst. rewrite Z.shiftl_0_r.
  symmetry. apply Z.mod_small.
  rewrite Z_of_uint64_lor'_ok.
  rewrite Z_of_uint64_alt.
  split. { apply Z_of_uint64_lower. } apply Z_of_uint64_upper.
}
assert(BS := to_Z_bounded sh). remember (to_Z sh) as s.
assert(SPos: 0 < s).
{
  enough (s <> 0) by lia.
  intro H. subst.
  replace 0 with (to_Z 0) in H by trivial.
  apply to_Z_inj in H.
  apply eqb_spec in H.
  rewrite H in Sh0.
  discriminate.
}
destruct a as (hi, lo).
rewrite uint63_testbit_Z.
unfold Z_of_uint64_lor'.
rewrite Int63.lsl_spec.
apply Z.bits_inj'. intros k Knonneg.
rewrite Z.lor_spec.
rewrite<- Z.shiftl_mul_pow2 by now subst.
rewrite<- Heqs.
assert (BN := to_Z_bounded lo). remember (to_Z lo) as n.
rewrite Z.shiftl_lor.
replace wB with (2^63) by trivial.
repeat rewrite<- Z.land_ones.
rewrite Z.land_lor_distr_l.
replace (Z.land (Z.shiftl ((if hi then 1 else 0) * 2 ^ 63) s) (Z.ones 64)) with 0.
3-4: now rewrite<- Z.leb_le.
2:{
  destruct hi. 2:{ rewrite Z.mul_0_l. rewrite Z.shiftl_0_l. rewrite Z.land_0_l. trivial. }
  symmetry.
  rewrite Z.mul_1_l.
  rewrite Z.shiftl_mul_pow2 by tauto.
  rewrite Z.land_ones by now rewrite<- Z.leb_le.
  rewrite<- Z.pow_add_r; try lia.
  replace (2 ^ (63 + s)) with (2^(s - 1) * 2^64).
  2:{ rewrite<- Z.pow_add_r; try f_equal; lia. }
  apply Z_mod_mult.
}
rewrite Z.lor_0_r.
repeat rewrite Z.land_spec.
repeat rewrite Z.testbit_ones_nonneg; try lia.
remember (Z.testbit (Z.shiftl n s) k) as x.
assert (CK: k <> 63 \/ k = 63) by lia.
case CK; clear CK; intro CK.
{
  replace (Z.testbit ((if Z.testbit n (to_Z (63 - sh)%int63) then 1 else 0) * 2 ^ 63) k) with false.
  2:{
    symmetry.
    destruct (Z.testbit n (to_Z (63 - sh)%int63)); [ rewrite Z.mul_1_l | rewrite Z.mul_0_l ].
    { apply Z.pow2_bits_false. lia. }
    apply Z.bits_0.
  }
  rewrite Bool.orb_false_r.
  f_equal.
  rewrite Arith2.Z_ltb_lt_quad. split; lia.
}
subst k x.
replace (63 <? 63) with false by trivial.
replace (63 <? 64) with true by trivial.
rewrite Bool.andb_false_r. rewrite Bool.orb_false_l. rewrite Bool.andb_true_r.
rewrite Arith2.Z_testbit_flag_mul_pow2 by lia.
rewrite Z.shiftl_spec by lia.
rewrite sub_spec. replace (to_Z 63) with 63 by trivial.
rewrite<- Heqs.
assert (WB63: 63 < wB) by now rewrite<- Z.ltb_lt.
assert (Q: (63 - s) mod wB = 63 - s \/ 63 < (63 - s) mod wB).
{
  assert(B: -wB < 63 - s) by lia.
  assert(WBNZ: wB <> 0) by discriminate.
  assert(D := Z.div_mod (63 - s) wB WBNZ).
  assert(WBPos: 0 < wB) by lia.
  assert(BQ := Z.mod_pos_bound (63 - s) wB WBPos).
  remember ((63 - s) mod wB) as q.
  clear Heqq.
  assert (L: -1 <= (63 - s) / wB) by nia.
  assert (U: (63 - s) / wB <= 0) by nia.
  assert (T: (63 - s) / wB = 0 \/ (63 - s) / wB = -1) by lia.
  case T; clear T; intro T; lia.
}
case Q; clear Q; intro Q. { now rewrite Q. }
assert (S63: 63 < s).
{
  apply Z.nle_gt. intro H.
  replace ((63 - s) mod wB) with (63 - s) in *.
  2:{
    rewrite Z.mod_small. { trivial. }
    lia.
  }
  lia.
}
rewrite (Z.testbit_neg_r n (63 - s)) by lia.
apply Arith2.Z_testbit_small. { tauto. }
refine (Z.lt_trans n wB _ _ _). { tauto. }
replace wB with (2^63) by trivial.
apply Z.pow_lt_mono_r; try lia.
apply Z.mod_pos_bound.
trivial. apply Q.
Qed.

Definition shl (a: uint64) (sh: uint64)
: uint64
:= match sh with
   | (false, sh63) => shl_uint63 a sh63
   | (true, _) => uint64_0
   end.

Lemma shl_ok (a: uint64) (sh: uint64):
  Z_of_uint64 (shl a sh) = Z.shiftl (Z_of_uint64 a) (Z_of_uint64 sh) mod 2 ^ 64.
Proof.
destruct sh as (sh_hi, sh_lo).
destruct sh_hi.
2:{ (* low case *)
  replace (shl a (false, sh_lo)) with (shl_uint63 a sh_lo) by trivial.
  replace (Z_of_uint64 (false, sh_lo)) with (Int63.to_Z sh_lo) by trivial.
  apply shl_uint63_ok.
}
(* high case *)
match goal with |- ?lhs = ?rhs => replace lhs with 0 by trivial end.
symmetry.
rewrite Z.shiftl_mul_pow2 by apply Z_of_uint64_lower.
replace (Z_of_uint64 (true, sh_lo)) with (Int63.to_Z sh_lo + wB) by trivial.
rewrite Z.pow_add_r. 2:{ apply Int63.to_Z_bounded. } 2:{ now unfold wB. }
rewrite Z.mul_assoc.
remember (Z_of_uint64 a * 2 ^ Int63.to_Z (sh_lo)%int63) as c. clear Heqc.
unfold wB. unfold size. replace (Z.of_nat 63) with 63%Z by trivial.
pose (k := 2 ^ 63 - 64).
assert (PosK: k > 0) by easy.
replace (2 ^ 63) with (k + 64) by lia.
rewrite Z.pow_add_r by lia.
rewrite Z.mul_assoc.
apply Z.mod_mul. easy.
Qed.

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

Definition bitwise_or (a b: uint64)
: uint64
:= ((fst a || fst b)%bool,  Int63.lor (snd a) (snd b)).

Lemma bitwise_or_ok (a b: uint64):
  Z_of_uint64 (bitwise_or a b) = (Z.lor (Z_of_uint64 a) (Z_of_uint64 b)).
Proof.
repeat rewrite<- Z_of_uint64_lor_ok.
destruct a as (a_hi, a_lo).
destruct b as (b_hi, b_lo).
unfold Z_of_uint64_lor. unfold bitwise_or.
destruct a_hi, b_hi;
  match goal with
  |- (if ?cond then _ else _) = ?rhs  => remember cond as c; cbn in Heqc; subst
  end;
  repeat rewrite lor_spec';
  replace (snd (_, a_lo)) with a_lo by trivial;
  replace (snd (_, b_lo)) with b_lo by trivial;
  remember (to_Z a_lo) as x;
  remember (to_Z b_lo) as y;
  repeat rewrite Z.lor_assoc; trivial.
{
  (* goal: Z.lor (Z.lor x y) wB = Z.lor (Z.lor (Z.lor x wB) y) wB *)
  repeat rewrite<- Z.lor_assoc. f_equal.
  rewrite Z.lor_comm.
  rewrite Z.lor_assoc.
  now replace (Z.lor wB wB) with wB by trivial.
}
(* goal: Z.lor (Z.lor x y) wB = Z.lor (Z.lor x wB) y *)
repeat rewrite<- Z.lor_assoc. f_equal.
apply Z.lor_comm.
Qed.

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

Definition bitwise_xor (a b: uint64)
: uint64
:= (xorb (fst a) (fst b),  Int63.lxor (snd a) (snd b)).

Lemma bitwise_xor_ok (a b: uint64):
  Z_of_uint64 (bitwise_xor a b) = (Z.lxor (Z_of_uint64 a) (Z_of_uint64 b)).
Proof.
repeat rewrite<- Z_of_uint64_lxor_ok.
destruct a as (a_hi, a_lo).
destruct b as (b_hi, b_lo).
unfold Z_of_uint64_lxor. unfold bitwise_xor.
destruct a_hi, b_hi;
  match goal with
  |- (if ?cond then _ else _) = ?rhs  => remember cond as c; cbn in Heqc; subst
  end;
  repeat rewrite lxor_spec';
  replace (snd (_, a_lo)) with a_lo by trivial;
  replace (snd (_, b_lo)) with b_lo by trivial;
  remember (to_Z a_lo) as x;
  remember (to_Z b_lo) as y;
  repeat rewrite Z.lxor_assoc; trivial.
{
  (* goal: Z.lxor x y = Z.lxor x (Z.lxor wB (Z.lxor y wB)) *)
  rewrite (Z.lxor_comm y wB). f_equal.
  rewrite<- Z.lxor_assoc.
  now replace (Z.lor wB wB) with wB by trivial.
}
f_equal. apply Z.lxor_comm.
Qed.

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

Definition bitwise_and (a b: uint64)
: uint64
:= ((fst a && fst b)%bool,  Int63.land (snd a) (snd b)).

Lemma bitwise_and_ok (a b: uint64):
  Z_of_uint64 (bitwise_and a b) = (Z.land (Z_of_uint64 a) (Z_of_uint64 b)).
Proof.
repeat rewrite<- Z_of_uint64_lor_ok.
destruct a as (a_hi, a_lo).
destruct b as (b_hi, b_lo).
unfold Z_of_uint64_lor. unfold bitwise_and.
destruct a_hi, b_hi;
  match goal with
  |- (if ?cond then _ else _) = ?rhs  => remember cond as c; cbn in Heqc; subst
  end;
  repeat rewrite land_spec';
  replace (snd (_, a_lo)) with a_lo by trivial;
  replace (snd (_, b_lo)) with b_lo by trivial;
  remember (to_Z a_lo) as x;
  remember (to_Z b_lo) as y;
  repeat rewrite Z.land_assoc; trivial.
{ apply Z.lor_land_distr_l. }
{
  rewrite Z.land_lor_distr_l.
  replace (Z.land wB y) with 0. { now rewrite Z.lor_0_r. }
  symmetry. rewrite Z.land_comm. apply Arith2.Z_land_pow2_small.
  { subst. apply to_Z_bounded. }
  rewrite<- Z.leb_le. trivial.
}
rewrite Z.land_lor_distr_r.
replace (Z.land x wB) with 0. { now rewrite Z.lor_0_r. }
symmetry. apply Arith2.Z_land_pow2_small.
{ subst. apply to_Z_bounded. }
rewrite<- Z.leb_le. trivial.
Qed.

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

Definition bitwise_not (a: uint64)
: uint64
:= (negb (fst a),  Int63.lxor (snd a) (of_Z (-1))).

Lemma bitwise_not_via_xor (a: uint64):
  bitwise_not a = bitwise_xor a uint64_max_value.
Proof.
trivial.
Qed.

Lemma bitwise_not_ok (a: uint64):
  Z_of_uint64 (bitwise_not a) = (Z.lnot (Z_of_uint64 a)) mod 2^64.
Proof.
rewrite bitwise_not_via_xor. rewrite bitwise_xor_ok.
rewrite<- Z.lxor_m1_r. rewrite<- Z.land_ones. 2: { now rewrite<- Z.leb_le. }
assert (L := Z_of_uint64_lower a).
assert (U := Z_of_uint64_upper a).
remember (Z_of_uint64 a) as x. clear Heqx.
rewrite uint64_max_value_ok.
replace (2 ^ 64 - 1) with (Z.ones 64) by trivial.
rewrite Z_land_lxor_distr_l.
f_equal.
symmetry. apply Z.land_ones_low. { assumption. }
apply Arith2.Z_log2_lt_pow2; try assumption.
now rewrite<- Z.ltb_lt.
Qed.

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

Definition eqb (a b: uint64)
: bool
:= let '(a_hi, a_lo) := a in
   let '(b_hi, b_lo) := b in
   (Bool.eqb a_hi b_hi && (a_lo =? b_lo))%bool%int63.

Lemma eqb_true (a b: uint64):
  eqb a b = true <-> a = b.
Proof.
unfold eqb. split; intro H.
{
  destruct a as (a_hi, a_lo), b as (b_hi, b_lo).
  apply Bool.andb_true_iff in H.
  destruct H as (Hi, Lo).
  apply Bool.eqb_prop in Hi.
  apply Int63.eqb_spec in Lo.
  now subst.
}
subst b. destruct a.
rewrite Bool.eqb_reflx.
rewrite Bool.andb_true_l.
apply Int63.eqb_spec. trivial.
Qed.

Definition is_nonzero (a: uint64)
: bool
:= let '(a_hi, a_lo) := a in
   (a_hi || (0 <? a_lo)%int63)%bool.

Lemma is_nonzero_via_eqb (a: uint64):
  is_nonzero a = negb (eqb a uint64_0).
Proof.
destruct a as (hi, lo). cbn.
destruct hi; cbn; trivial.
apply Bool.eq_true_iff_eq.
assert (B := proj1 (Int63.to_Z_bounded lo)).
rewrite Int63.ltb_spec.
assert (E := Int63.eqb_spec lo 0).
replace (to_Z 0) with 0%Z by trivial.
destruct (lo =? 0)%int63.
{ assert (L := proj1 E eq_refl). now subst. }
apply Z.le_lteq in B.
enough (L: 0 <> φ (lo)%int63) by tauto.
intro H. symmetry in H.
rewrite<- (of_to_Z lo) in E.
rewrite H in E.
cbn in E.
assert (Bad := proj2 E eq_refl). discriminate.
Qed.

Lemma is_nonzero_false (a: uint64):
  is_nonzero a = false <-> a = uint64_0.
Proof.
rewrite is_nonzero_via_eqb. rewrite<- eqb_true.
apply Bool.negb_false_iff.
Qed.

Lemma is_nonzero_true (a: uint64):
  is_nonzero a = true <-> a <> uint64_0.
Proof.
remember (is_nonzero a) as nz; symmetry in Heqnz.
destruct nz.
{
  enough (a <> uint64_0) by tauto.
  intro H. now subst.
}
apply is_nonzero_false in Heqnz. now subst.
Qed.

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

Definition byte_of_uint64 (i: uint64)
:= Byte (is_nonzero (bitwise_and i uint64_128))
        (is_nonzero (bitwise_and i uint64_64))
        (is_nonzero (bitwise_and i uint64_32))
        (is_nonzero (bitwise_and i uint64_16))
        (is_nonzero (bitwise_and i uint64_8))
        (is_nonzero (bitwise_and i uint64_4))
        (is_nonzero (bitwise_and i uint64_2))
        (is_nonzero (bitwise_and i uint64_1)).

Definition uint64_of_byte (b: byte)
:= match b with
   | Byte b7 b6 b5 b4 b3 b2 b1 b0 =>
      let a7 := if b7 then uint64_128 else uint64_0 in
      let a6 := if b6 then  bitwise_or uint64_64 a7 else a7 in
      let a5 := if b5 then  bitwise_or uint64_32 a6 else a6 in
      let a4 := if b4 then  bitwise_or uint64_16 a5 else a5 in
      let a3 := if b3 then  bitwise_or  uint64_8 a4 else a4 in
      let a2 := if b2 then  bitwise_or  uint64_4 a3 else a3 in
      let a1 := if b1 then  bitwise_or  uint64_2 a2 else a2 in
                if b0 then  bitwise_or  uint64_1 a1 else a1
   end.

Lemma byte_of_uint64_of_byte (b: byte):
  byte_of_uint64 (uint64_of_byte b) = b.
Proof.
destruct b as (a7, a6, a5, a4, a3, a2, a1, a0).
destruct a7; destruct a6; destruct a5; destruct a4;
destruct a3; destruct a2; destruct a1; destruct a0; trivial.
Qed.

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

Definition uint64_of_be_bytes (b: byte * byte * byte * byte * byte * byte * byte * byte)
: uint64
:= let '(b7, b6, b5, b4, b3, b2, b1, b0) := b in
   let a7 :=                shl (uint64_of_byte b7) uint64_56  in
   let a6 := bitwise_or a7 (shl (uint64_of_byte b6) uint64_48) in
   let a5 := bitwise_or a6 (shl (uint64_of_byte b5) uint64_40) in
   let a4 := bitwise_or a5 (shl (uint64_of_byte b4) uint64_32) in
   let a3 := bitwise_or a4 (shl (uint64_of_byte b3) uint64_24) in
   let a2 := bitwise_or a3 (shl (uint64_of_byte b2) uint64_16) in
   let a1 := bitwise_or a2 (shl (uint64_of_byte b1) uint64_8)  in
             bitwise_or a1 (uint64_of_byte b0).

Definition uint64_to_be_bytes (a: uint64)
: byte * byte * byte * byte * byte * byte * byte * byte
:= (byte_of_uint64 (shr a uint64_56),
    byte_of_uint64 (shr a uint64_48),
    byte_of_uint64 (shr a uint64_40),
    byte_of_uint64 (shr a uint64_32),
    byte_of_uint64 (shr a uint64_24),
    byte_of_uint64 (shr a uint64_16),
    byte_of_uint64 (shr a uint64_8),
    byte_of_uint64 a).

Definition uint64_to_le_bytes (a: uint64)
: byte * byte * byte * byte * byte * byte * byte * byte
:= (byte_of_uint64 a,
    byte_of_uint64 (shr a uint64_8),
    byte_of_uint64 (shr a uint64_16),
    byte_of_uint64 (shr a uint64_24),
    byte_of_uint64 (shr a uint64_32),
    byte_of_uint64 (shr a uint64_40),
    byte_of_uint64 (shr a uint64_48),
    byte_of_uint64 (shr a uint64_56)).

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

Definition uint64_of_N_divmod (n: N)
: N * uint64
:= (N.shiftr n 64, (N.testbit n 63, Int63.of_Z (Z.of_N n))).

Definition uint64_of_pos_divmod (p: positive)
: N * uint64
:= uint64_of_N_divmod (N.pos p).

Definition head0 (a: uint64)
: int
:= let (hi, lo) := a in
   if hi
     then 0
     else succ (head0 lo).

Definition head0_uint64 (a: uint64)
: uint64
:= (false, head0 a).

Definition tail0 (a: uint64)
: int
:= let (hi, lo) := a in
   if (lo =? 0)%int63
     then if hi then 63 else 64
     else tail0 lo.

Definition tail0_uint64 (a: uint64)
: uint64
:= (false, tail0 a).

Definition compare (a b: uint64)
: comparison
:= match a, b with
   | (true, x), (true, y) | (false, x), (false, y) => compare x y
   | (true, _), (false, _) => Gt
   | (false, _), (true, _) => Lt
   end.

Definition eq0 (a: uint64)
: bool
:= let (hi, lo) := a in
   if hi
     then false
     else (lo =? 0)%int63.

Definition succ (a: uint64)
: uint64
:= let (hi, lo) := a in
   match succc lo with
   | C0 n => (hi, n)
   | C1 n => (negb hi, n)
   end.