(*
  Autor(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

(* * Halting problem for one counter machines CM1_HALT  *)

(*
  Problem(s):
    One Counter Machine Halting (CM1_HALT)
*)

Require Import List Nat.

Definition State : Set := nat.
(* a configuration consists of a state and a counter value *)
Record Config : Set := mkConfig { state : State; value : nat }.

(* an instruction (n, q) maps
  a configuration (p, c) to (q, c * (n+2) / (n+1)) if c is divisible by (n+1)
  and otherwise to (p+1, c) *)
Definition Instruction : Set := State * nat.

(* an one counter machine is a list of instructions *)
Definition Cm1 : Set := list Instruction.

(* one counter machine step function *)
Definition step (M: Cm1) (x: Config) : Config :=
  match (value x), (nth_error M (state x)) with
  | 0, _ => x (* halting configuration *)
  | _, None => x (* halting configuration *)
  | _, Some (p, n) =>
      match modulo (value x) (n+1) with
      | 0 => {| state := p; value := ((value x) * (n+2)) / (n+1) |}
      | _ => {| state := 1 + state x; value := value x |}
      end
  end.

(* unfold step if the configuration is decomposed *)
Arguments step _ !x /.

(* halting configuration property *)
Definition halting (M : Cm1) (x: Config) : Prop := step M x = x.

(* One Counter Machine Halting Problem (with Denominators at most 4) *)
Definition CM1_HALT : { M : Cm1 | Forall (fun '(_, n) => n < 4) M } -> Prop :=
  fun '(exist _ M _) =>
    exists n, halting M (Nat.iter n (step M) {| state := 0; value := 1 |}).


Require Export P03.

Theorem lookup_relate:
  forall k t cts ,   Abs t cts -> lookup k t =  cts (int2Z k).
Proof.
  intros.
  induction H; try eauto.
  simpl. unfold t_update. unfold combine.
  (* There are a bunch of cases that compare between k0 and k.
     In this situation, you can just stack destructs (or bdestruct in this problem)
     and use 'try nia' to eliminate cases that are non-sense. *)
  bdestruct (ltb k k0); bdestruct (int2Z k0 =? int2Z k);
    bdestruct (int2Z k <? int2Z k0); bdestruct (ltb k0 k); try nia; eauto.
Qed.


Require Export GeoCoq.Axioms.tarski_axioms.

Section Definitions.

Context `{Tn:Tarski_neutral_dimensionless}.

(** Definition 2.10. *)

Definition OFSC A B C D A' B' C' D' :=
  Bet A B C /\ Bet A' B' C' /\
  Cong A B A' B' /\ Cong B C B' C' /\
  Cong A D A' D' /\ Cong B D B' D'.

(** Definition 3.8. *)

Definition Bet_4 A1 A2 A3 A4 :=
   Bet A1 A2 A3 /\ Bet A2 A3 A4 /\ Bet A1 A3 A4 /\ Bet A1 A2 A4.

(** Definition 4.1. *)

Definition IFSC A B C D A' B' C' D' :=
   Bet A B C /\ Bet A' B' C' /\
   Cong A C A' C' /\ Cong B C B' C' /\
   Cong A D A' D' /\ Cong C D C' D'.

(** Definition 4.4. *)

Definition Cong_3 A B C A' B' C' :=
  Cong A B A' B' /\ Cong A C A' C' /\ Cong B C B' C'.

Definition Cong_4 P1 P2 P3 P4 Q1 Q2 Q3 Q4 :=
  Cong P1 P2 Q1 Q2 /\ Cong P1 P3 Q1 Q3 /\ Cong P1 P4 Q1 Q4 /\
  Cong P2 P3 Q2 Q3 /\ Cong P2 P4 Q2 Q4 /\ Cong P3 P4 Q3 Q4.

Definition Cong_5 P1 P2 P3 P4 P5 Q1 Q2 Q3 Q4 Q5 :=
  Cong P1 P2 Q1 Q2 /\ Cong P1 P3 Q1 Q3 /\
  Cong P1 P4 Q1 Q4 /\ Cong P1 P5 Q1 Q5 /\
  Cong P2 P3 Q2 Q3 /\ Cong P2 P4 Q2 Q4 /\ Cong P2 P5 Q2 Q5 /\
  Cong P3 P4 Q3 Q4 /\ Cong P3 P5 Q3 Q5 /\ Cong P4 P5 Q4 Q5.

(** Definition 4.10. *)

Definition Col A B C := Bet A B C \/ Bet B C A \/ Bet C A B.

(** Definition 4.15. *)

Definition FSC A B C D A' B' C' D' :=
  Col A B C /\ Cong_3 A B C A' B' C' /\ Cong A D A' D' /\ Cong B D B' D'.

(** Definition 5.4. *)

Definition Le A B C D := exists E, Bet C E D /\ Cong A B C E.

Definition Ge A B C D := Le C D A B.

(** Definition 5.14. *)

Definition Lt A B C D := Le A B C D /\ ~ Cong A B C D.

Definition Gt A B C D := Lt C D A B.

(** Definition 6.1. *)

Definition Out P A B := A <> P /\ B <> P /\ (Bet P A B \/ Bet P B A).

(** Definition 6.22. *)

Definition Inter A1 A2 B1 B2 X :=
 B1 <> B2 /\ (exists P, Col P B1 B2 /\ ~ Col P A1 A2) /\
 Col A1 A2 X /\ Col B1 B2 X.

(** Definition 7.1. *)

Definition Midpoint M A B := Bet A M B /\ Cong A M M B.

(** Definition 8.1. *)

Definition Per A B C := exists C', Midpoint B C C' /\ Cong A C A C'.

(** Definition 8.11. *)

Definition Perp_at X A B C D :=
  A <> B /\ C <> D /\ Col X A B /\ Col X C D /\
  forall U V, Col U A B -> Col V C D -> Per U X V.

(** Definition 8.11. *)

Definition Perp A B C D := exists X, Perp_at X A B C D.

(** Definition 9.1. *)

Definition TS A B P Q :=
  ~ Col P A B /\ ~ Col Q A B /\ exists T, Col T A B /\ Bet P T Q.

(** Definition 9.7. *)

Definition OS A B P Q := exists R, TS A B P R /\ TS A B Q R.

(** Satz 9.33. *)

Definition Coplanar A B C D :=
  exists X, (Col A B X /\ Col C D X) \/
            (Col A C X /\ Col B D X) \/
            (Col A D X /\ Col B C X).

(** Definition 9.37 *)

Definition TSP A B C P Q :=
  ~ Coplanar A B C P /\ ~ Coplanar A B C Q /\ (exists T, Coplanar A B C T /\ Bet P T Q).

(** Definition 9.40 *)

Definition OSP A B C P Q :=
  exists R, TSP A B C P R /\ TSP A B C Q R.

(** Definition 10.3. *)

Definition ReflectL P' P A B :=
  (exists X, Midpoint X P P' /\ Col A B X) /\ (Perp A B P P' \/ P = P').

Definition Reflect P' P A B :=
 (A <> B /\ ReflectL P' P A B) \/ (A = B /\ Midpoint A P P').

Definition ReflectL_at M P' P A B :=
  (Midpoint M P P' /\ Col A B M) /\ (Perp A B P P' \/ P = P').

Definition Reflect_at M P' P A B :=
 (A <> B /\ ReflectL_at M P' P A B) \/ (A = B /\ A = M /\ Midpoint M P P').

(** Definition 11.2. *)

Definition CongA A B C D E F :=
  A <> B /\ C <> B /\ D <> E /\ F <> E /\
  exists A', exists C', exists D', exists F',
  Bet B A A' /\ Cong A A' E D /\
  Bet B C C' /\ Cong C C' E F /\
  Bet E D D' /\ Cong D D' B A /\
  Bet E F F' /\ Cong F F' B C /\
  Cong A' C' D' F'.

(** Definition 11.23. *)

Definition InAngle P A B C :=
  A <> B /\ C <> B /\ P <> B /\ exists X, Bet A X C /\ (X = B \/ Out B X P).

(** Definition 11.27. *)

Definition LeA A B C D E F := exists P, InAngle P D E F /\ CongA A B C D E P.

Definition GeA A B C D E F := LeA D E F A B C.

(** Definition 11.38. *)

Definition LtA A B C D E F := LeA A B C D E F /\ ~ CongA A B C D E F.

Definition GtA A B C D E F := LtA D E F A B C.

(** Definition 11.39. *)

Definition Acute A B C :=
  exists A' B' C', Per A' B' C' /\ LtA A B C A' B' C'.

(** Definition 11.39. *)

Definition Obtuse A B C :=
  exists A' B' C', Per A' B' C' /\ LtA A' B' C' A B C.

(** Definition 11.59. *)

Definition Orth_at X A B C U V :=
  ~ Col A B C /\ U <> V /\ Coplanar A B C X /\ Col U V X /\
  forall P Q, Coplanar A B C P -> Col U V Q -> Per P X Q.

Definition Orth A B C U V := exists X, Orth_at X A B C U V.

(** Definition 12.2. *)

Definition Par_strict A B C D :=
  Coplanar A B C D /\ ~ exists X, Col X A B /\ Col X C D.

(** Definition 12.3. *)

Definition Par A B C D :=
  Par_strict A B C D \/ (A <> B /\ C <> D /\ Col A C D /\ Col B C D).

(** Definition 13.4. *)

Definition Q_Cong l := exists A B, forall X Y, Cong A B X Y <-> l X Y.

Definition Len A B l := Q_Cong l /\ l A B.

Definition Q_Cong_Null l := Q_Cong l /\ exists A, l A A.

Definition EqL (l1 l2 : Tpoint -> Tpoint -> Prop) :=
  forall A B, l1 A B <-> l2 A B.

Definition Q_CongA a :=
  exists A B C,
    A <> B /\ C <> B /\ forall X Y Z, CongA A B C X Y Z <-> a X Y Z.

Definition Ang A B C a := Q_CongA a /\ a A B C.

Definition Ang_Flat a := Q_CongA a /\ forall A B C, a A B C -> Bet A B C.

Definition EqA (a1 a2 : Tpoint -> Tpoint -> Tpoint -> Prop) :=
  forall A B C, a1 A B C <-> a2 A B C.

(** Definition 13.9. *)

Definition Perp2 A B C D P :=
  exists X Y, Col P X Y /\ Perp X Y A B /\ Perp X Y C D.

Definition Q_CongA_Acute a :=
  exists A B C,
    Acute A B C /\ forall X Y Z, CongA A B C X Y Z <-> a X Y Z.

Definition Ang_Acute A B C a := Q_CongA_Acute a /\ a A B C.

Definition Q_CongA_nNull a := Q_CongA a /\ forall A B C, a A B C -> ~ Out B A C.

Definition Q_CongA_nFlat a := Q_CongA a /\ forall A B C, a A B C -> ~ Bet A B C.

Definition Q_CongA_Null a := Q_CongA a /\ forall A B C, a A B C -> Out B A C.

Definition Q_CongA_Null_Acute a :=
  Q_CongA_Acute a /\ forall A B C, a A B C -> Out B A C.

Definition is_null_anga' a :=
  Q_CongA_Acute a /\ exists A B C, a A B C /\ Out B A C.

Definition Q_CongA_nNull_Acute a :=
  Q_CongA_Acute a /\ forall A B C, a A B C -> ~ Out B A C.

Definition Lcos lb lc a :=
  Q_Cong lb /\ Q_Cong lc /\ Q_CongA_Acute a /\
  (exists A B C, (Per C B A /\ lb A B /\ lc A C /\ a B A C)).

Definition Eq_Lcos la a lb b := exists lp, Lcos lp la a /\ Lcos lp lb b.

Definition Lcos2 lp l a b := exists la, Lcos la l a /\ Lcos lp la b.

Definition Eq_Lcos2 l1 a b l2 c d :=
  exists lp, Lcos2 lp l1 a b /\ Lcos2 lp l2 c d.

Definition Lcos3 lp l a b c :=
  exists la lab, Lcos la l a /\ Lcos lab la b /\ Lcos lp lab c.

Definition Eq_Lcos3 l1 a b c l2 d e f :=
  exists lp, Lcos3 lp l1 a b c /\ Lcos3 lp l2 d e f.

(** Definition 14.1. *)

Definition Ar1 O E A B C :=
 O <> E /\ Col O E A /\ Col O E B /\ Col O E C.

Definition Ar2 O E E' A B C :=
 ~ Col O E E' /\ Col O E A /\ Col O E B /\ Col O E C.

(** Definition 14.2. *)

Definition Pj A B C D := Par A B C D \/ C = D.

(** Definition 14.3. *)

Definition Sum O E E' A B C :=
 Ar2 O E E' A B C /\
 exists A' C',
 Pj E E' A  A' /\ Col O E' A' /\
 Pj O E  A' C' /\
 Pj O E' B  C' /\
 Pj E' E C' C.

Definition Proj P Q A B X Y :=
  A <> B /\ X <> Y /\ ~Par A B X Y  /\ Col A B Q /\ (Par P Q X Y \/ P = Q).

Definition Sump O E E' A B C :=
 Col O E A /\ Col O E B /\
 exists A' C' P',
   Proj A A' O E' E E' /\
   Par O E A' P' /\
   Proj B C' A' P' O E' /\
   Proj C' C O E E E'.

(** Definition 14.4. *)

Definition Prod O E E' A B C :=
 Ar2 O E E' A B C /\
 exists B', Pj E E' B B' /\ Col O E' B' /\ Pj E' A B' C.

Definition Prodp O E E' A B C :=
 Col O E A /\ Col O E B /\
 exists B', Proj B B' O E' E E' /\ Proj B' C O E A E'.

(** Definition 14.8. *)

Definition Opp O E E' A B :=
 Sum O E E' B A O.

(** Definition 14.38. *)

Definition Diff O E E' A B C :=
  exists B', Opp O E E' B B' /\ Sum O E E' A B' C.

Definition sum3 O E E' A B C S :=
  exists AB, Sum O E E' A B AB /\ Sum O E E' AB C S.

Definition Sum4 O E E' A B C D S :=
  exists ABC, sum3 O E E' A B C ABC /\ Sum O E E' ABC D S.

Definition sum22 O E E' A B C D S :=
  exists AB CD, Sum O E E' A B AB /\ Sum O E E' C D CD /\ Sum O E E' AB CD S.

Definition Ar2_4 O E E' A B C D :=
  ~ Col O E E' /\ Col O E A /\ Col O E B /\ Col O E C /\ Col O E D.

(** Definition 14.34. *)

Definition Ps O E A := Out O A E.

Definition Ng O E A := A <> O /\ E <> O /\ Bet A O E .

(** Definition 14.38. *)

Definition LtP O E E' A B := exists D, Diff O E E' B A D /\ Ps O E D.

Definition LeP O E E' A B := LtP O E E' A B \/ A = B.

Definition Length O E E' A B L :=
 O <> E /\ Col O E L /\ LeP O E E' O L /\ Cong O L A B.

(** Definition 15.1. *)

Definition Is_length O E E' A B L :=
 Length O E E' A B L \/ (O = E /\ O = L).

Definition Sumg O E E' A B C :=
  Sum O E E' A B C \/ (~ Ar2 O E E' A B B /\ C = O).

Definition Prodg O E E' A B C :=
  Prod O E E' A B C \/ (~ Ar2 O E E' A B B /\ C = O).

Definition PythRel O E E' A B C :=
  Ar2 O E E' A B C /\
  ((O = B /\ (A = C \/ Opp O E E' A C)) \/
   exists B', Perp O B' O B /\ Cong O B' O B /\ Cong O C A B').

Definition SignEq O E A B := Ps O E A /\ Ps O E B \/ Ng O E A /\ Ng O E B.

Definition LtPs O E E' A B := exists D, Ps O E D /\ Sum O E E' A D B.

(** Definition 16.1. *)
(** We skip the case of dimension 1. *)

Definition Cs O E S U1 U2 :=
   O <> E /\ Cong O E S U1 /\ Cong O E S U2 /\ Per U1 S U2.

(** Q is the orthogonal projection of P on the line AB. *)

Definition Projp P Q A B :=
  A <> B /\ ((Col A B Q /\ Perp A B P Q) \/ (Col A B P /\ P = Q)).

(** Definition 16.5. *)
(** P is of coordinates (X,Y) in the grid SU1U2 using unit length OE. *)

Definition Cd O E S U1 U2 P X Y :=
  Cs O E S U1 U2 /\ Coplanar P S U1 U2 /\
  (exists PX, Projp P PX S U1 /\ Cong_3 O E X S U1 PX) /\
  (exists PY, Projp P PY S U2 /\ Cong_3 O E Y S U2 PY).

(** Strict betweenness *)

Definition BetS A B C : Prop := Bet A B C /\ A <> B /\ B <> C.

(** Definition of the sum of segments.
    SumS A B C D E F means that AB + CD = EF. *)

Definition SumS A B C D E F := exists P Q R,
  Bet P Q R /\ Cong P Q A B /\ Cong Q R C D /\ Cong P R E F.

(** PQ is the perpendicular bisector of segment AB *)

Definition Perp_bisect P Q A B := ReflectL A B P Q /\ A <> B.

Definition Perp_bisect_bis P Q A B :=
  exists I, Perp_at I P Q A B /\ Midpoint I A B.

Definition Is_on_perp_bisect P A B := Cong A P P B.

(** Definition of the sum of angles.
    SumA A B C D E F G H I means that ABC + DEF = GHI. *)

Definition SumA A B C D E F G H I :=
  exists J, CongA C B J D E F /\ ~ OS B C A J /\ Coplanar A B C J /\ CongA A B J G H I.

(** The SAMS predicate describes the fact that the sum of the two angles is "at most straight" *)

Definition SAMS A B C D E F :=
  A <> B /\ (Out E D F \/ ~ Bet A B C) /\
  exists J, CongA C B J D E F /\ ~ OS B C A J /\ ~ TS A B C J /\ Coplanar A B C J.

(** Supplementary angles *)

Definition SuppA A B C D E F :=
  A <> B /\ exists A', Bet A B A' /\ CongA D E F C B A'.

(** Definition of the sum of the interior angles of a triangle.
    TriSumA A B C D E F means that the sum of the angles of the triangle ABC
    is equal to the angle DEF *)

Definition TriSumA A B C D E F :=
  exists G H I, SumA A B C B C A G H I /\ SumA G H I C A B D E F.

(** The difference between a straight angle and the sum of the angles of the triangle ABC.
    It is a non-oriented angle, so we can't discriminate between positive and negative difference *)

Definition Defect A B C D E F := exists G H I,
  TriSumA A B C G H I /\ SuppA G H I D E F.

(** P is on the circle of center A going through B *)

Definition OnCircle P A B := Cong A P A B.

(** P is inside or on the circle of center A going through B *)

Definition InCircle P A B := Le A P A B.

(** P is outside or on the circle of center A going through B *)

Definition OutCircle P A B := Le A B A P.

(** P is strictly inside the circle of center A going through B *)

Definition InCircleS P A B := Lt A P A B.

(** P is strictly outside the circle of center A going through B *)

Definition OutCircleS P A B := Lt A B A P.

(** The line segment AB is a diameter of the circle of center O going through P *)

Definition Diam A B O P := Bet A O B /\ OnCircle A O P /\ OnCircle B O P.

Definition EqC A B C D :=
 forall X, OnCircle X A B <-> OnCircle X C D.

(** The circles of center A passing through B and
                of center C passing through D intersect
                in two distinct points P and Q. *)

Definition InterCCAt A B C D P Q :=
  ~ EqC A B C D /\
  P<>Q /\ OnCircle P C D /\ OnCircle Q C D /\ OnCircle P A B /\ OnCircle Q A B.

(** The circles of center A passing through B and
                of center C passing through D
                have two distinct intersections. *)

Definition InterCC A B C D :=
 exists P Q, InterCCAt A B C D P Q.

(** The circles of center A passing through B and
                of center C passing through D
                are tangent. *)

Definition TangentCC A B C D := exists !X, OnCircle X A B /\ OnCircle X C D.

(** The line AB is tangent to the circle OP *)

Definition Tangent A B O P := exists !X, Col A B X /\ OnCircle X O P.

Definition TangentAt A B O P T :=
  Tangent A B O P /\ Col A B T /\ OnCircle T O P.

(** The points A, B, C and D belong to a same circle *)

Definition Concyclic A B C D := Coplanar A B C D /\
  exists O P, OnCircle A O P /\ OnCircle B O P /\ OnCircle C O P /\ OnCircle D O P.

(** The points A, B, C and D are concyclic or lined up *)

Definition Concyclic_gen A B C D :=
  Concyclic A B C D \/ (Col A B C /\ Col A B D /\ Col A C D /\ Col B C D).

(** C is on the graduation based on [AB] *)
Inductive Grad : Tpoint -> Tpoint -> Tpoint -> Prop :=
  | grad_init : forall A B, Grad A B B
  | grad_stab : forall A B C C',
                  Grad A B C ->
                  Bet A C C' -> Cong A B C C' ->
                  Grad A B C'.

Definition Reach A B C D := exists B', Grad A B B' /\ Le C D A B'.

(** There exists n such that AC = n times AB and DF = n times DE *)
Inductive Grad2 : Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint ->
                  Prop :=
  | grad2_init : forall A B D E, Grad2 A B B D E E
  | grad2_stab : forall A B C C' D E F F',
                   Grad2 A B C D E F ->
                   Bet A C C' -> Cong A B C C' ->
                   Bet D F F' -> Cong D E F F' ->
                   Grad2 A B C' D E F'.

(** Graduation based on the powers of 2 *)
Inductive GradExp : Tpoint -> Tpoint -> Tpoint -> Prop :=
  | gradexp_init : forall A B, GradExp A B B
  | gradexp_stab : forall A B C C',
                     GradExp A B C ->
                     Bet A C C' -> Cong A C C C' ->
                     GradExp A B C'.

Inductive GradExp2 : Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint ->
                     Prop :=
  | gradexp2_init : forall A B D E, GradExp2 A B B D E E
  | gradexp2_stab : forall A B C C' D E F F',
                      GradExp2 A B C D E F ->
                      Bet A C C' -> Cong A C C C' ->
                      Bet D F F' -> Cong D F F F' ->
                      GradExp2 A B C' D E F'.

(** There exists n such that the angle DEF is congruent to n times the angle ABC *)
Inductive GradA : Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint ->
                  Prop :=
  | grada_init : forall A B C D E F, CongA A B C D E F -> GradA A B C D E F
  | grada_stab : forall A B C D E F G H I,
                   GradA A B C D E F ->
                   SAMS D E F A B C -> SumA D E F A B C G H I ->
                   GradA A B C G H I.

(** There exists n such that the angle DEF is congruent to 2^n times the angle ABC *)
Inductive GradAExp : Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint -> Tpoint ->
                     Prop :=
  | gradaexp_init : forall A B C D E F, CongA A B C D E F -> GradAExp A B C D E F
  | gradaexp_stab : forall A B C D E F G H I,
                      GradAExp A B C D E F ->
                      SAMS D E F D E F -> SumA D E F D E F G H I ->
                      GradAExp A B C G H I.

(** Parallelogram *)

Definition Parallelogram_strict A B A' B' :=
  TS A A' B B' /\ Par A B A' B' /\ Cong A B A' B'.

Definition Parallelogram_flat A B A' B' :=
  Col A B A' /\ Col A B B' /\
  Cong A B A' B' /\ Cong A B' A' B /\
  (A <> A' \/ B <> B').

Definition Parallelogram A B A' B' :=
  Parallelogram_strict A B A' B' \/ Parallelogram_flat A B A' B'.

Definition Plg A B C D :=
  (A <> C \/ B <> D) /\ exists M, Midpoint M A C /\ Midpoint M B D.

(** Rhombus *)

Definition Rhombus A B C D := Plg A B C D /\ Cong A B B C.

(** Rectangle *)

Definition Rectangle A B C D := Plg A B C D /\ Cong A C B D.

(** Square *)

Definition Square A B C D := Rectangle A B C D /\ Cong A B B C.

(** Kite *)

Definition Kite A B C D := Cong B C C D /\ Cong D A A B.

(** Saccheri *)

Definition Saccheri A B C D :=
  Per B A D /\ Per A D C /\ Cong A B C D /\ OS A D B C.

(** Lambert *)

Definition Lambert A B C D :=
  A <> B /\ B <> C /\ C <> D /\ A <> D /\ Per B A D /\ Per A D C /\ Per A B C /\ Coplanar A B C D.

(** Vector *)

Definition EqV A B C D := Parallelogram A B D C \/ A = B /\ C = D.

Definition SumV A B C D E F := forall D', EqV C D B D' -> EqV A D' E F.

Definition SumV_exists A B C D E F := exists D', EqV B D' C D /\ EqV A D' E F.

Definition Same_dir A B C D :=
  A = B /\ C = D \/ exists D', Out C D D' /\ EqV A B C D'.

Definition Opp_dir A B C D := Same_dir A B D C.

(** Projections *)

Definition CongA_3 A B C A' B' C' :=
  CongA A B C A' B' C' /\ CongA B C A B' C' A' /\ CongA C A B C' A' B'.

End Definitions.


Require Import SetoidList.
Require OrderedType.
Require Import Orders.

(** Some preliminary results  **)
Instance not_symmetric (A : Type) (R: relation A) `{Symmetric A R} : Symmetric (fun x y => ~R x y).
Proof. intros ? ? Hnot HR. apply Hnot. symmetry. assumption. Qed.

Instance InA_compat {A : Type} : Proper (subrelation ==> eq ==> eq ==> impl) (@InA A).
Proof.
intros inA inB Hin. do 6 intro; subst. intro Hl. rewrite InA_alt in *.
destruct Hl as [? [? ?]]. eexists. split; eauto.
Qed.

Definition full_relation {A : Type} : relation A := fun x y : A => True.

(** Conversion module between the two kinds of [OrderedType]. **)
Module OTconvert (O : OrderedType) : OrderedType.OrderedType
          with Definition t := O.t
          with Definition eq := O.eq
          with Definition lt := O.lt.

  Definition t := O.t.
  Definition eq := O.eq.
  Definition lt := O.lt.

  Definition eq_refl : forall x, eq x x := reflexivity.
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof. intros. now symmetry. Qed.
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof. intros. etransitivity; eassumption. Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof. intros. etransitivity; eassumption. Qed.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof. intros ? ? Hlt Heq. rewrite Heq in Hlt. revert Hlt. apply StrictOrder_Irreflexive. Qed.

  Lemma compare : forall x y : t, OrderedType.Compare lt eq x y.
  Proof.
  intros x y. assert (H :=  (O.compare_spec x y)).  destruct (O.compare x y).
  - constructor 2. now inversion H.
  - constructor 1. now inversion H.
  - constructor 3. now inversion H.
  Qed.

  Definition eq_dec := O.eq_dec.
End OTconvert.


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

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

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

(* This is repeated, we have proven mult_assoc as part of other theorems *)
Theorem theorem0 : forall (x : natural) (y : natural) (z : natural), eq (mult (mult x y) z) (mult x (mult y z)).
Proof.
Admitted.


Require Export Logics.
Require Export Coq.Setoids.Setoid.

Lemma or_elim {A} :
  A \/ A <-> A.
Proof.
  split => [aa | a].
  induction aa.
  done.
  done.
  by apply or_introl.
Qed.

(* 4.1 An Axiom systems*)

Axiom Class : Type.
Axiom In : Class -> Class -> Prop.
Notation "x ∈ X" := (In x X) (at level 50).

Axiom Equal : forall X Y,
  (forall Z, Z ∈ X <-> Z ∈ Y) <-> X = Y.

Definition Inclusion (X Y : Class) :=
  forall Z, Z ∈ X -> Z ∈ Y.
Notation "X ⊂ Y" := (Inclusion X Y)(at level 10).

Definition ProperInclusion (X Y : Class) :=
  X ⊂ Y /\ X <> Y.
Notation "X ⊆ Y" := (ProperInclusion X Y) (at level 10).

Definition M X :=
  exists Y , X ∈ Y.

Definition Pr X :=
  ~ M X.

Axiom Classify : (Class -> Prop) -> Class.
Notation "{| P |}"  := (Classify P) (at level 0).

Axiom in_cls :
  forall P u, M u -> u ∈ ({|P|}) <-> P u.

Axiom Empty : Class.
Notation "∅" := (Empty).

Axiom notin_empty :
  forall x, M x -> ~ x ∈ ∅.

Axiom empty_set :
  M ∅.

Definition Pair x y :=
  {| fun u => u = x \/ u = y |}.

Axiom pair_set :
  forall x y, M x -> M y -> M (Pair x y).

Theorem in_pair x y u (u_ : M u):
  u ∈ Pair x y <-> u = x \/ u = y.
Proof.
  rewrite in_cls => //.
Qed.


(* We want a dependently typed recursive function.  The output type is itself
  described by a recursive function. *)

Fixpoint bool_nat_type (n:nat) : Set :=
  match n with 0 => nat | 1 => bool | S (S n) => bool_nat_type n end.

(* The difficult point is to describe the computation at each
   recursive step, knowing that sometimes this computation deals with
   boolean values, while at other times it deals with integer
   values.  The trick is to discover that computations can actually
   always be described by the same function as for the
   pre-predecessor.

   A dependently typed pattern-matching construct is need. *)

Require Import Bool.

Fixpoint bool_nat_fun_aux (n:nat) :  bool_nat_type n -> bool_nat_type n :=
 match n return bool_nat_type n -> bool_nat_type n with
   0 => S | 1 => negb | S (S n) => bool_nat_fun_aux n
 end.

(* The function is then easy to describe.  We can use "Compute"
   to check that its value is always as required. *)

Fixpoint bool_nat_fun (n:nat) : bool_nat_type n :=
 match n return bool_nat_type n with
   0 => 0
 | 1 => true
 | S (S n) => bool_nat_fun_aux n (bool_nat_fun n)
 end.

(** Tests :

Compute (bool_nat_fun 6).

Compute (bool_nat_fun 7).

Compute (bool_nat_fun 9).

Compute (bool_nat_fun 7 : bool).

Compute (bool_nat_fun 6 : nat).

*)

(* Defining a function of this form was fun, but will it ever be
   useful? *)


Require Import IntuitionisticLogic.base.
Require Import IntuitionisticLogic.Wf.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Relations.Relation_Operators.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Setoids.Setoid.
Local Open Scope IPC_scope.

Module RelationDef.
Section RelationDef.

Context {A: Type}.

Section Intersection.

Variables R1 R2: relation A.

Definition intersection x y := R1 x y /\ R2 x y.

End Intersection.

Arguments union {A} R1 R2 x y /.
Arguments intersection R1 R2 x y /.

Variables R eqA: relation A.

Class Total: Prop :=
  totality: forall x y, R x y \/ R y x.

Class StrictTotal: Prop :=
  strict_totality: forall x y, R x y \/ x = y \/ R y x.

Class StrictTotalViaEquiv: Prop :=
  strict_totality_via_equiv: forall x y, R x y \/ eqA x y \/ R y x.

Class Antisymmetric: Prop :=
  antisymmetry: forall x y, R x y -> R y x -> x = y.

Class AntisymViaEquiv: Prop :=
  antisymmetry_via_equiv: forall x y, R x y -> R y x -> eqA x y.

Class IrreflViaEquiv: Prop :=
  irreflexivity_via_equiv: forall x y, eqA x y -> R x y -> False.

Class WeakTotalOrder: Prop := {
  WeakTotalOrder_Reflexive: Reflexive R;
  WeakTotalOrder_Transitive: Transitive R;
  WeakTotalOrder_Total: Total
}.

Class TotalOrder: Prop := {
  TotalOrder_Reflexive: Reflexive R;
  TotalOrder_Antisymmetric: Antisymmetric;
  TotalOrder_Transitive: Transitive R;
  TotalOrder_Total: Total
}.

Class StrictTotalOrder: Prop := {
  StrictTotalOrder_Irreflexive: Irreflexive R;
  StrictTotalOrder_Transitive: Transitive R;
  StrictTotalOrder_StrictTotal: StrictTotal
}.

Class StrictTotalOrderViaEquiv: Prop := {
  StrictTotalOrderViaEquiv_EqIsEquiv: Equivalence eqA;
  StrictTotalOrderViaEquiv_IrreflViaEquiv: IrreflViaEquiv;
  StrictTotalOrderViaEquiv_Transitive: Transitive R;
  StrictTotalOrderViaEquiv_StrictTotal: StrictTotalViaEquiv
}.

Class StrictWellOrder: Prop := {
  StrictWellOrder_StrictTotalOrder: StrictTotalOrder;
  StrictWellOrder_WellFounded: well_founded R
}.

End RelationDef.

Lemma Irreflexive_is_IrreflViaEquiv:
  forall {A} (R: relation A),
  Irreflexive R <-> IrreflViaEquiv R eq.
Proof.
  intros; split; intros; hnf in *; intros.
  + subst.
    apply H in H1; auto.
  + specialize (H x x eq_refl).
    exact H.
Qed.

End RelationDef.

Import RelationDef.
Arguments union {A} R1 R2 x y /.
Arguments intersection {A} R1 R2 x y /.

Module StrictTotalOrderViaEquiv.
Section StrictTotalOrderViaEquiv.

Variable A: Type.
Variables R eqA: relation A.
Variable Order: StrictTotalOrderViaEquiv R eqA.

Lemma disjointed_3cases: forall x y,
  (R x y /\ ~ eqA x y /\ ~ R y x) \/
  (~ R x y /\ eqA x y /\ ~ R y x) \/
  (~ R x y /\ ~ eqA x y /\ R y x).
Proof.
  intros.
  pose proof StrictTotalOrderViaEquiv_StrictTotal _ _ x y.
  pose proof StrictTotalOrderViaEquiv_IrreflViaEquiv _ _ x y.
  pose proof StrictTotalOrderViaEquiv_IrreflViaEquiv _ _ y x.
  pose proof StrictTotalOrderViaEquiv_IrreflViaEquiv _ _ x x.
  pose proof StrictTotalOrderViaEquiv_Transitive _ _ x y x.
  inversion Order.
  pose proof Equivalence_Reflexive x.
  pose proof Equivalence_Symmetric x y.
  pose proof Equivalence_Symmetric y x.
  tauto.
Qed.

Lemma LeftProperViaEquiv: forall x x0 y, eqA x x0 -> R x y -> R x0 y.
Proof.
  intros.
  pose proof disjointed_3cases x0 y.
  pose proof disjointed_3cases x x0.
  pose proof disjointed_3cases x y.
  pose proof @Equivalence_Transitive _ eqA (StrictTotalOrderViaEquiv_EqIsEquiv _ _) x x0 y.
  pose proof StrictTotalOrderViaEquiv_Transitive _ _ x y x0.
  tauto.
Qed.

Lemma RightProperViaEquiv: forall x y y0, eqA y0 y -> R x y -> R x y0.
Proof.
  intros.
  pose proof disjointed_3cases x y.
  pose proof disjointed_3cases y0 y.
  pose proof disjointed_3cases x y0.
  pose proof @Equivalence_Transitive _ eqA (StrictTotalOrderViaEquiv_EqIsEquiv _ _) x y0 y.
  pose proof StrictTotalOrderViaEquiv_Transitive _ _ y0 x y.
  tauto.
Qed.

Instance ProperViaEquiv: Proper (eqA ==> eqA ==> iff) R.
Proof.
  intro; intros; intro; intros.
  inversion Order.
  pose proof Equivalence_Symmetric _ _  H.
  pose proof Equivalence_Symmetric _ _  H0.
  pose proof LeftProperViaEquiv x y x0 H.
  pose proof LeftProperViaEquiv y x x0 H1.
  pose proof RightProperViaEquiv y x0 y0 H2.
  pose proof RightProperViaEquiv y y0 x0 H0.
  tauto.
Qed.

End StrictTotalOrderViaEquiv.

Theorem StrictTotalOrder_is_StrictTotalOrderViaEquiv:
  forall {A} (R: relation A), StrictTotalOrder R <-> StrictTotalOrderViaEquiv R eq.
Proof.
  intros; split; intros; inversion H; constructor; auto.
  + apply eq_equivalence.
  + apply Irreflexive_is_IrreflViaEquiv; auto.
  + apply Irreflexive_is_IrreflViaEquiv; auto.
Qed.

End StrictTotalOrderViaEquiv.

Section Operators.

Variable A: Type.
Variable R1 R2 eqA: relation A.

Lemma intersection_Reflexive: Reflexive R1 -> Reflexive R2 -> Reflexive (intersection R1 R2).
Proof.
  intros ? ? x.
  split; apply reflexivity.
Qed.

Lemma intersection_Symmetric: Symmetric R1 -> Symmetric R2 -> Symmetric (intersection R1 R2).
Proof.
  intros ? ? x y [? ?].
  split; apply symmetry; auto.
Qed.

Lemma intersection_Transitive: Transitive R1 -> Transitive R2 -> Transitive (intersection R1 R2).
Proof.
  intros ? ? x y z [? ?] [? ?].
  split; eapply transitivity; eauto.
Qed.

Lemma union_IrreflViaEquiv: IrreflViaEquiv R1 eqA -> IrreflViaEquiv R2 eqA -> IrreflViaEquiv (union R1 R2) eqA.
Proof.
  intros ? ? x y ? [? | ?].
  + exact (H x y H1 H2).
  + exact (H0 x y H1 H2).
Qed.

Theorem intersection_Equivalence: Equivalence R1 -> Equivalence R2 -> Equivalence (intersection R1 R2).
Proof.
  intros.
  constructor.
  + apply intersection_Reflexive; apply Equivalence_Reflexive.
  + apply intersection_Symmetric; apply Equivalence_Symmetric.
  + apply intersection_Transitive; apply Equivalence_Transitive.
Qed.

End Operators.

Section BiKeyOrder.

Variable A: Type.
Variable R1 R2 eqA1 eqA2: relation A.

Definition BiKey := union R1 (intersection eqA1 R2).

Theorem BiKey_StrictTotalOrderViaEquiv:
  StrictTotalOrderViaEquiv R1 eqA1 ->
  StrictTotalOrderViaEquiv R2 eqA2 ->
  StrictTotalOrderViaEquiv BiKey (intersection eqA1 eqA2).
Proof.
  intros; unfold BiKey.
  inversion H.
  inversion H0.
  constructor.
  + apply intersection_Equivalence; auto.
  + intros x y; simpl.
    specialize (StrictTotalOrderViaEquiv_IrreflViaEquiv0 x y).
    specialize (StrictTotalOrderViaEquiv_IrreflViaEquiv1 x y).
    tauto.
  + intros x y z [? | [? ?]] [? | [? ?]]; simpl.
    - left. eapply StrictTotalOrderViaEquiv_Transitive0; eauto.
    - left. eapply StrictTotalOrderViaEquiv.RightProperViaEquiv with (eqA := eqA1); eauto.
      symmetry; auto.
    - left. eapply StrictTotalOrderViaEquiv.LeftProperViaEquiv with (eqA := eqA1); eauto.
      symmetry; auto.
    - right; split.
      * eapply transitivity; eauto.
      * eapply transitivity; eauto.
  + intros x y; simpl.
    pose proof StrictTotalOrderViaEquiv.disjointed_3cases _ R1 _ _ x y.
    pose proof StrictTotalOrderViaEquiv.disjointed_3cases _ R2 _ _ x y.
    pose proof @symmetry _ eqA1 _ x y.
    pose proof @symmetry _ eqA1 _ y x.
    tauto.
Qed.

Lemma BiKey_StrictTotalOrder:
  StrictTotalOrderViaEquiv R1 eqA1 ->
  StrictTotalOrder R2 ->
  StrictTotalOrder BiKey.
Proof.
Admitted.

Section enumerate.

Variable venv: Var_env.
Variable lt_var: Var -> Var -> Prop.
Hypothesis Wf: well_founded lt_var.
Hypothesis TO: TotalOrder lt_var.

Fixpoint level (e: Term) : nat :=
  match e with
  | andp e1 e2 => max (level e1) (level e2) + 1
  | orp e1 e2 => max (level e1) (level e2) + 1
  | impp e1 e2 => max (level e1) (level e2) + 1
  | falsep => 0
  | varp _ => 0
  end.

Fixpoint trivial_lt (e1 e2: Term): Prop :=
  match e1, e2 with
  | falsep, falsep => False
  | falsep, _ => True
  | _, falsep => False
  | varp v1, varp v2 => lt_var v1 v2
  | varp _, _ => True
  | _, varp _ => False
  | andp e11 e12, andp e21 e22 => trivial_lt e11 e21 \/ (e11 = e21 /\ trivial_lt e12 e22)
  | andp _ _, _ => True
  | _, andp _ _ => False
  | orp e11 e12, orp e21 e22 => trivial_lt e11 e21 \/ (e11 = e21 /\ trivial_lt e12 e22)
  | orp _ _, _ => True
  | _, orp _ _ => False
  | impp e11 e12, impp e21 e22 => trivial_lt e11 e21 \/ (e11 = e21 /\ trivial_lt e12 e22)
  end.

Definition lt_Term (e1 e2: Term): Prop :=
  (level e1 < level e2) \/ (level e1 = level e2 /\ trivial_lt e1 e2).

Definition


Require Import ZArith.
From QuickChick Require Import QuickChick.
From ExtLib Require Import Monad.
From ExtLib.Data.Monads Require Import OptionMonad.
Import QcNotation.
Import MonadNotation.
From Coq Require Import List.
Import ListNotations.

From RBT Require Import Impl Spec.

Open Scope Z_scope.

Fixpoint genTree (lo hi : Z) (c : Color)  (f: nat) (h : nat) : G (option Tree)
:=
if lo >? hi then ret None else
match f with
| S f' =>
  match h, c with
  | O, R => ret (Some E)
  | O, B => oneOf [ ret (Some E)
                        ; k <- choose (lo, hi) ;;
                          v <- arbitrary ;;
                          ret (Some (T R E k v E))]
  | S h', R =>
      let margin := (2^(2*(Z.of_nat h) - 1) - 1) in
      if (lo + margin >? hi - margin) then  ret None else
      c' <- ret B ;;
      k <- choose (lo + margin, hi - margin) ;;
      v <- arbitrary ;;
      l <- genTree lo (k - 1)  B f' h' ;;
      r <- genTree (k + 1) hi  B f' h' ;;
       match l, r with
      | Some tl, Some tr => ret (Some (T c' tl k v tr))
      | _, _ => ret None
      end

  | S h', B =>
      let margin := (2^(2*(Z.of_nat h)) - 1) in
      if (lo + margin >? hi - margin) then ret None else
      c' <- arbitrary ;;
      k <- choose (lo + margin, hi - margin) ;;
      v <- arbitrary ;;
      let h'' := match c' with R => h | B => h' end in
      l <- genTree lo (k - 1) c' f' h'' ;;
      r <- genTree (k + 1) hi c' f' h'' ;;
      match l, r with
      | Some tl, Some tr => ret (Some (T c' tl k v tr))
      | _, _ => ret None
      end
  end
| _ => ret None
end.

Axiom fuel : nat. Extract Constant fuel => "10000".

Global Instance genTreeSized : GenSized (option Tree) :=
{| arbitrarySized x :=
    let y := Nat.min x 2 in
      genTree 0 (2^(Z.of_nat(y)*2)) R fuel y |}.

Definition gSized :=
    x <- choose (0, 3)%nat;;
    genTree 0 (2^(Z.of_nat(x)*2)) R fuel x
.

(* --------------------- Tests --------------------- *)

Definition test_prop_InsertValid :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun v =>
        (prop_InsertValid t k v)))).

(*! QuickChick test_prop_InsertValid. *)

Definition test_prop_DeleteValid :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
        prop_DeleteValid t k)).

(*! QuickChick test_prop_DeleteValid. *)

Definition test_prop_InsertPost :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
     forAll arbitrary (fun v =>
        prop_InsertPost t k k' v)))).

(*! QuickChick test_prop_InsertPost. *)

Definition test_prop_DeletePost :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
        prop_DeletePost t k k'))).

(*! QuickChick test_prop_DeletePost. *)

Definition test_prop_InsertModel :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun v =>
        prop_InsertModel t k v))).

(*! QuickChick test_prop_InsertModel. *)

Definition test_prop_DeleteModel :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
            prop_DeleteModel t k)).

(*! QuickChick test_prop_DeleteModel. *)

Definition test_prop_InsertInsert :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
    forAll arbitrary (fun v =>
    forAll arbitrary (fun v' =>
        prop_InsertInsert t k k' v v'))))).

(*! QuickChick test_prop_InsertInsert. *)

Definition test_prop_InsertDelete :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
    forAll arbitrary (fun v =>
        prop_InsertDelete t k k' v)))).

(*! QuickChick test_prop_InsertDelete. *)

Definition test_prop_DeleteInsert :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
    forAll arbitrary (fun v' =>
        prop_DeleteInsert t k k' v')))).

(*! QuickChick test_prop_DeleteInsert. *)

Definition test_prop_DeleteDelete :=
    forAllMaybe gSized (fun t =>
    forAll arbitrary (fun k =>
    forAll arbitrary (fun k' =>
        prop_DeleteDelete t k k'))).

(*! QuickChick test_prop_DeleteDelete. *)


Require Import List.
Export ListNotations.
Require Export ZArith.
Require Import Init.Datatypes.

Inductive IPE: Type :=
 | zero_pe
 | one_pe.

Inductive PE : Type :=
 | i_pe      : IPE -> PE
 | u_pe      : PE.

Definition P : Type := list PE.

Function beq_ipe (i i' : IPE) : bool :=
  match i, i' with
    | zero_pe, zero_pe => true
    | one_pe, one_pe => true
    | _, _ => false
  end.

Function beq_pe (p p' : PE) : bool :=
  match p, p' with
    | i_pe x, i_pe y => beq_ipe x y
    | u_pe, u_pe => true
    | _, _ => false
  end.

Function beq_path (p q : P) : bool :=
  match p, q with
    | [], [] => true
    | x :: p', y :: q' => andb (beq_pe x y) (beq_path p' q')
    | _  , _ => false
  end.


 Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Theorem zero_nbeq_plus_1 : forall n : nat,
  beq_nat 0 (n + 1) = false.
Proof.
intros n. destruct n.
- reflexivity.
- reflexivity.
Qed.


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

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

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

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) : natural
           := match mult_arg0, mult_arg1 with
              | Zero, n => Zero
              | Succ n, m => plus (mult n m) m
              end.

Fixpoint qmult (qmult_arg0 : natural) (qmult_arg1 : natural) (qmult_arg2 : natural) : natural
           := match qmult_arg0, qmult_arg1, qmult_arg2 with
              | Zero, n, m => m
              | Succ n, m, p => qmult n m (plus p m)
              end.

Lemma plus_succ : forall (x y : natural), plus x (Succ y) = Succ (plus x y).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_assoc : forall (x y z : natural), plus (plus x y) z = plus x (plus y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_zero : forall (x : natural), plus x Zero = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma plus_commut : forall (x y : natural), plus x y = plus y x.
Proof.
   intros.
   induction x.
   - lfind. Admitted.


Require Import Pointed.
Require Import WildCat HFiber.
Require Import Truncations.
Require Import Algebra.Groups.
Require Import Homotopy.HomotopyGroup.

Local Open Scope pointed_scope.
Local Open Scope nat_scope.

(** 8.8.1 *)
Definition isequiv_issurj_tr0_isequiv_ap
           `{Univalence} {A B : Type} (f : A -> B)
           {i  : IsSurjection (Trunc_functor 0 f)}
           {ii : forall x y, IsEquiv (@ap _ _ f x y)}
  : IsEquiv f.
Proof.
  apply (equiv_isequiv_ap_isembedding f)^-1 in ii.
  srapply isequiv_surj_emb.
  srapply BuildIsSurjection.
  cbn; intro b.
  pose proof (@center _ (i (tr b))) as p.
  revert p.
  apply Trunc_functor.
  apply sig_ind.
  srapply Trunc_ind.
  intros a p.
  apply (equiv_path_Tr _ _)^-1 in p.
  strip_truncations.
  exists a.
  exact p.
Defined.

(** 8.8.2 *)
Definition isequiv_isbij_tr0_isequiv_loops
           `{Univalence} {A B : Type} (f : A -> B)
           {i  : IsEquiv (Trunc_functor 0 f)}
           {ii : forall x, IsEquiv (fmap loops (pmap_from_point f x)) }
  : IsEquiv f.
Proof.
  srapply (isequiv_issurj_tr0_isequiv_ap f).
  intros x y.
  apply isequiv_inhab_codomain.
  intro p.
  apply (ap (@tr 0 _)) in p.
  apply (@equiv_inj _ _ _ i (tr x) (tr y)) in p.
  apply (equiv_path_Tr _ _)^-1 in p.
  strip_truncations.
  destruct p.
  cbn in ii.
  snrapply (isequiv_homotopic _ (H:=ii x)).
  exact (fun _ => concat_1p _ @ concat_p1 _).
Defined.

(** When the types are 0-connected and the map is pointed, just one [loops_functor] needs to be checked. *)
Definition isequiv_is0connected_isequiv_loops
           `{Univalence} {A B : pType} `{IsConnected 0 A} `{IsConnected 0 B}
           (f : A ->* B)
           (e : IsEquiv (fmap loops f))
  : IsEquiv f.
Proof.
  apply isequiv_isbij_tr0_isequiv_loops.
  (** The pi_0 condition is trivial because [A] and [B] are 0-connected. *)
  1: apply isequiv_contr_contr.
  (** Since [A] is 0-connected, it's enough to check the [loops_functor] condition for the basepoint. *)
  rapply conn_point_elim.
  (** The [loops_functor] condition for [pmap_from_point f _] is equivalent to the [loops_functor] condition for [f] with its given pointing. *)
  srapply isequiv_homotopic'.
  - exact (equiv_concat_lr (point_eq f) (point_eq f)^ oE (Build_Equiv _ _ _ e)).
  - intro r.
    simpl.
    hott_simpl.
Defined.

(** Truncated Whitehead's principle (8.8.3) *)
Definition whiteheads_principle
           {ua : Univalence} {A B : Type} {f : A -> B}
           (n : trunc_index) {H0 : IsTrunc n A} {H1 : IsTrunc n B}
           {i  : IsEquiv (Trunc_functor 0 f)}
           {ii : forall (x : A) (k : nat), IsEquiv (fmap (Pi k.+1) (pmap_from_point f x)) }
  : IsEquiv f.
Proof.
  revert A B H0 H1 f i ii.
  induction n as [|n IHn].
  1: intros; apply isequiv_contr_contr.
  intros A B H0 H1 f i ii.
  nrefine (@isequiv_isbij_tr0_isequiv_loops ua _ _ f i _).
  intro x.
  nrefine (isequiv_homotopic (@ap _ _ f x x) _).
  2:{intros p; cbn.
     symmetry; exact (concat_1p _ @ concat_p1 _). }
  pose proof (@istrunc_paths _ _ H0 x x) as h0.
  pose proof (@istrunc_paths _ _ H1 (f x) (f x)) as h1.
  nrefine (IHn (x=x) (f x=f x) h0 h1 (@ap _ _ f x x) _ _).
  - pose proof (ii x 0) as h2.
    unfold is0functor_pi in h2; cbn in h2.
    refine (@isequiv_homotopic _ _ _ _ h2 _).
    apply (O_functor_homotopy (Tr 0)); intros p.
    exact (concat_1p _ @ concat_p1 _).
  - intros p k; revert p.
    assert (h3 : forall (y:A) (q:x=y),
               IsEquiv (fmap (Pi k.+1) (pmap_from_point (@ap _ _ f x y) q))).
    2:exact (h3 x).
    intros y q. destruct q.
    snrefine (isequiv_homotopic _ _).
    1: exact (fmap (Pi k.+1) (fmap loops (pmap_from_point f x))).
    2:{ rapply (fmap2 (Pi k.+1)); srefine (Build_pHomotopy _ _).
        - intros p; cbn.
          refine (concat_1p _ @ concat_p1 _).
        - reflexivity. }
    nrefine (isequiv_commsq _ _ _ _ (fmap_pi_loops k.+1 (pmap_from_point f x))).
    2-3:refine (equiv_isequiv (pi_loops _ _)).
    exact (ii x k.+1).
Defined.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

Require Import Coq.Arith.Peano_dec.
Require Import Coq.Lists.SetoidList.
Require Import Coq.omega.Omega.

Require Import Metalib.CoqUniquenessTac.

(* *********************************************************************** *)
(** * Examples *)

(** The examples go through more smoothly if we declare [eq_nat_dec]
    as a hint. *)

Hint Resolve eq_nat_dec : eq_dec.

(* *********************************************************************** *)
(** ** Predicates on natural numbers *)

Scheme le_ind' := Induction for le Sort Prop.

Lemma le_unique : forall (x y : nat) (p q: x <= y), p = q.
Proof.
  induction p using le_ind';
  uniqueness 1;
  assert False by omega; intuition.

Qed.

(* ********************************************************************** *)
(** ** Predicates on lists *)

(** Uniqueness of proofs for predicates on lists often comes up when
    discussing extensional equality on finite sets, as implemented by
    the FSets library. *)

Section Uniqueness_Of_SetoidList_Proofs.

  Variable A : Type.
  Variable R : A -> A -> Prop.

  Hypothesis R_unique : forall (x y : A) (p q : R x y), p = q.
  Hypothesis list_eq_dec : forall (xs ys : list A), {xs = ys} + {xs <> ys}.

  Scheme lelistA_ind' := Induction for lelistA Sort Prop.
  Scheme sort_ind'    := Induction for sort Sort Prop.
  Scheme eqlistA_ind' := Induction for eqlistA Sort Prop.

  Theorem lelistA_unique :
    forall (x : A) (xs : list A) (p q : lelistA R x xs), p = q.
  Proof. induction p using lelistA_ind'; uniqueness 1. Qed.

  Theorem sort_unique :
    forall (xs : list A) (p q : sort R xs), p = q.
  Proof. induction p using sort_ind'; uniqueness 1. apply lelistA_unique. Qed.

  Theorem eqlistA_unique :
    forall (xs ys : list A) (p q : eqlistA R xs ys), p = q.
  Proof. induction p using eqlistA_ind'; uniqueness 2. Qed.

End Uniqueness_Of_SetoidList_Proofs.

(* *********************************************************************** *)
(** ** Vectors *)

(** [uniqueness] can show that the only vector of length zero is the
    empty vector.  This shows that the tactic is not restricted to
    working only on [Prop]s. *)

Inductive vector (A : Type) : nat -> Type :=
  | vnil : vector A 0
  | vcons : forall (n : nat) (a : A), vector A n -> vector A (S n).

Theorem vector_O_eq : forall (A : Type) (v : vector A 0),
  v = vnil _.
Proof. intros. uniqueness 1. Qed.


Inductive tree : Set :=
  | empty : tree
  | node : tree -> tree -> tree. (* Constructor that takes to subtrees and returns a tree *)

Print tree_ind.

Fixpoint size t := (* Returns the size of a tree *)
  match t with
    | empty => 0
    | node t1 t2 => S (plus(size t1)(size t2))
  end.

Fixpoint swap t := (* Swaps nodes in a tree with their subtrees ?*)
  match t with
    | empty => empty
    | node t1 t2 => node (swap t1) (swap t2)
  end.

Theorem swap_size: forall t, size t = size (swap t).

Proof. intros t. induction t.
  - auto. (* Tactic that will prove base cases IDK why *)
  - simpl. f_equal. (* got rid of the successors *) rewrite <- IHt1. rewrite <- IHt2. reflexivity.
Qed.


Inductive bool  : Type :=
    | true      : bool
    | false     : bool
    .

Definition negb (b:bool) : bool :=
    match b with
    | true  => false
    | false => true
    end.

Definition andb (b1:bool)(b2:bool) : bool :=
    match b1 with
    |   true    => b2
    |   false   => false
    end.

Definition orb (b1:bool)(b2:bool) : bool :=
    match b1 with
    |   true    => true
    |   false   => b2
    end.

Infix "&&" := andb.
Infix "||" := orb.

Lemma lem_bool : forall b:bool, b = true \/ b = false.
Proof.
    destruct b.
        - left. reflexivity.
        - right. reflexivity.
Qed.

Lemma negb_involutive : forall b:bool,
    negb (negb b) = b.
Proof.
    intros b. destruct b.
    - reflexivity.
    - reflexivity.
Qed.

Lemma andb_comm : forall b c:bool,
    andb b c = andb c b.
Proof.
    intros b c. destruct b.
    - destruct c.
        + reflexivity.
        + reflexivity.
    - destruct c.
        + reflexivity.
        + reflexivity.
Qed.

Lemma orb_comm : forall b c: bool,
    orb b c = orb c b.
Proof.
    destruct b, c.
    - reflexivity.
    - reflexivity.
    - reflexivity.
    - reflexivity.
Qed.

Lemma andb_true_iff : forall b c:bool,
    b && c = true <-> b = true /\ c = true.
Proof.
    intros b c. split.
    - intros H. split.
        + destruct b eqn: H'.
            { reflexivity. }
            { inversion H. }
        + destruct c eqn: H'.
            { reflexivity. }
            { rewrite andb_comm in H. inversion H. }
    - intros [H1 H2]. rewrite H1, H2. reflexivity.
Qed.

Lemma orb_true_iff : forall b c:bool,
    b || c = true <-> b = true \/ c = true.
Proof.
    intros b c. split.
    - intros H. destruct b eqn: H'.
        + left. reflexivity.
        + right. exact H.
    - intros [H|H].
        + rewrite H. reflexivity.
        + rewrite H. rewrite orb_comm. reflexivity.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (z : natural) (y : natural) (lf2 : natural) (lf1 : natural)
  : natural := plus Zero (plus Zero lf1).


(****************************************************************************

 Pullbacks and equivalences

 Content:
 1. Any two pullbacks are equivalent
 2. Objects equivalent to pullbacks are pullbacks themselves

 ****************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.TransportLaws.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles.
Require Import UniMath.Bicategories.Limits.Pullbacks.

Local Open Scope cat.

(**
 1. Any two pullbacks are equivalent
 *)
Section UmpMorEquiv.
  Context {B : bicat}
          {b₁ b₂ b₃ : B}
          {f : b₁ --> b₃}
          {g : b₂ --> b₃}
          (cone₁ cone₂ : pb_cone f g)
          (H₁ : has_pb_ump cone₁)
          (H₂ : has_pb_ump cone₂).

  Definition pb_ump_mor_left_adjoint_equivalence_unit_pr1
    : id₁ cone₂ · pb_cone_pr1 cone₂
      ==>
      pr1 (pr1 H₁ cone₂) · pb_ump_mor H₂ cone₁ · pb_cone_pr1 cone₂
    := lunitor _
       • (pb_ump_mor_pr1 H₁ cone₂)^-1
       • (_ ◃ (pb_ump_mor_pr1 H₂ cone₁)^-1)
       • lassociator _ _ _.

  Definition pb_ump_mor_left_adjoint_equivalence_unit_pr2
    : id₁ cone₂ · pb_cone_pr2 cone₂
      ==>
      pr1 (pr1 H₁ cone₂) · pb_ump_mor H₂ cone₁ · pb_cone_pr2 cone₂
    := lunitor _
       • (pb_ump_mor_pr2 H₁ cone₂)^-1
       • (_ ◃ (pb_ump_mor_pr2 H₂ cone₁)^-1)
       • lassociator _ _ _.

  Definition pb_ump_mor_left_adjoint_equivalence_unit_cell
    : (_ ◃ pb_cone_cell cone₂)
      • lassociator _ _ _
      • (pb_ump_mor_left_adjoint_equivalence_unit_pr2 ▹ _)
      • rassociator _ _ _
      =
      lassociator _ _ _
      • (pb_ump_mor_left_adjoint_equivalence_unit_pr1 ▹ _)
      • rassociator _ _ _
      • (_ ◃ pb_cone_cell cone₂).
  Proof.
    unfold pb_ump_mor_left_adjoint_equivalence_unit_pr1.
    unfold pb_ump_mor_left_adjoint_equivalence_unit_pr2.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lunitor_triangle.
      apply idpath.
    }
    etrans.
    {
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      apply idpath.
    }
    refine (!_).
    etrans.
    {
      rewrite !vassocr.
      rewrite lunitor_triangle.
      rewrite !vassocl.
      apply idpath.
    }
    apply maponpaths.
    use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ].
    rewrite !vassocl.
    rewrite <- lwhisker_lwhisker_rassociator.
    rewrite <- rassociator_rassociator.
    refine (!_).
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      rewrite id2_left.
      apply idpath.
    }
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rassociator_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite (pb_ump_mor_cell H₂).
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !vassocl.
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite rassociator_lassociator.
      rewrite lwhisker_id2.
      rewrite id2_left.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp, rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker, lwhisker_id2.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      do 2 apply maponpaths.
      apply maponpaths_2.
      exact (pb_ump_mor_cell H₁ cone₂).
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    }
    etrans.
    {
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite !vassocl.
      apply idpath.
    }
    do 2 apply maponpaths.
    rewrite rwhisker_lwhisker_rassociator.
    apply idpath.
  Qed.

  Definition pb_ump_mor_left_adjoint_equivalence_unit
    : id₁ cone₂
      ==>
      pr1 (pr1 H₁ cone₂) · pb_ump_mor H₂ cone₁.
  Proof.
    use (pb_ump_cell H₂) ; cbn.
    - exact pb_ump_mor_left_adjoint_equivalence_unit_pr1.
    - exact pb_ump_mor_left_adjoint_equivalence_unit_pr2.
    - exact pb_ump_mor_left_adjoint_equivalence_unit_cell.
  Defined.

  Definition pb_ump_mor_left_adjoint_equivalence_unit_inv2cell
    : is_invertible_2cell pb_ump_mor_left_adjoint_equivalence_unit.
  Proof.
    use is_invertible_2cell_pb_ump_cell.
    - unfold pb_ump_mor_left_adjoint_equivalence_unit_pr1.
      is_iso.
    - unfold pb_ump_mor_left_adjoint_equivalence_unit_pr2.
      is_iso.
  Defined.
End UmpMorEquiv.

Definition pb_ump_mor_left_adjoint_equivalence
           {B : bicat}
           {b₁ b₂ b₃ : B}
           {f : b₁ --> b₃}
           {g : b₂ --> b₃}
           (cone₁ cone₂ : pb_cone f g)
           (H₁ : has_pb_ump cone₁)
           (H₂ : has_pb_ump cone₂)
  : left_adjoint_equivalence (pb_ump_mor H₁ cone₂).
Proof.
  use equiv_to_adjequiv.
  simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
  - exact (pb_ump_mor H₂ cone₁).
  - exact (pb_ump_mor_left_adjoint_equivalence_unit cone₁ cone₂ H₁ H₂).
  - exact ((pb_ump_mor_left_adjoint_equivalence_unit_inv2cell cone₂ cone₁ H₂  H₁)^-1).
  - apply pb_ump_mor_left_adjoint_equivalence_unit_inv2cell.
  - apply is_invertible_2cell_inv.
Defined.

(**
 2. Objects equivalent to pullbacks are pullbacks themselves
 *)
Section IdEquivalenceToPB.
  Context {B : bicat}
          {b₁ b₂ b₃ : B}
          {f : b₁ --> b₃}
          {g : b₂ --> b₃}
          {q : B}
          {qpr1 qpr1' : q --> b₁}
          {qpr2 qpr2' : q --> b₂}
          (qγ : invertible_2cell (qpr1 · f) (qpr2 · g))
          (qγ' : invertible_2cell (qpr1' · f) (qpr2' · g))
          (H₂ : has_pb_ump (make_pb_cone q qpr1' qpr2' qγ'))
          (lpr1 : invertible_2cell qpr1 qpr1')
          (lpr2 : invertible_2cell qpr2 qpr2')
          (lc : qγ • (lpr2 ▹ g) = (lpr1 ▹ f) • qγ').

  Definition id_left_adjoint_equivalence_to_pb_ump_1
    : pb_ump_1 (make_pb_cone q qpr1 qpr2 qγ).
  Proof.
    intro qc.
    use make_pb_1cell.
    - exact (pb_ump_mor H₂ qc).
    - exact (comp_of_invertible_2cell
               (lwhisker_of_invertible_2cell _ lpr1)
               (pb_ump_mor_pr1 H₂ qc)).
    - exact (comp_of_invertible_2cell
               (lwhisker_of_invertible_2cell _ lpr2)
               (pb_ump_mor_pr2 H₂ qc)).
    - abstract
        (cbn ;
         use (vcomp_rcancel (_ ◃ (lpr2 ▹ g))) ;
         [ is_iso ; apply property_from_invertible_2cell | ] ;
         rewrite lwhisker_vcomp ;
         rewrite lc ;
         rewrite <- lwhisker_vcomp ;
         refine (maponpaths (λ z, _ • z) (pb_ump_mor_cell H₂ qc) @ _) ;
         cbn ;
         rewrite !vassocr ;
         rewrite rwhisker_lwhisker ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite <- rwhisker_vcomp ;
         rewrite !vassocl ;
         do 3 apply maponpaths ;
         rewrite rwhisker_lwhisker_rassociator ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         rewrite rwhisker_vcomp ;
         rewrite !vassocl ;
         rewrite lwhisker_vcomp ;
         rewrite vcomp_linv ;
         rewrite lwhisker_id2 ;
         rewrite id2_right ;
         apply idpath).
  Defined.

  Section UMP2.
    Context {qc : B}
            {φ ψ : qc --> q}
            (α : φ · qpr1 ==> ψ · qpr1)
            (β : φ · qpr2 ==> ψ · qpr2)
            (p : (φ ◃ qγ) • lassociator _ _ _ • (β ▹ g) • rassociator _ _ _
                 =
                 lassociator _ _ _ • (α ▹ f) • rassociator _ _ _ • (ψ ◃ qγ)).

    Lemma id_left_adjoint_equivalence_to_pb_ump_2_cell_eq
      : (φ ◃ qγ')
          • lassociator _ _ _
          • (((φ ◃ lpr2 ^-1) • β • (ψ ◃ lpr2)) ▹ g)
          • rassociator _ _ _
        =
        lassociator _ _ _
        • (((φ ◃ lpr1 ^-1) • α • (ψ ◃ lpr1)) ▹ f)
        • rassociator ψ qpr1' f
        • (ψ ◃ qγ').
    Proof.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      refine (!_).
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite <- lc.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lwhisker_vcomp.
        rewrite vcomp_rinv.
        rewrite lwhisker_id2.
        rewrite id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        rewrite <- rwhisker_lwhisker_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite p.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite lwhisker_vcomp.
      rewrite lc.
      rewrite <- lwhisker_vcomp.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_lwhisker_rassociator.
      apply idpath.
    Qed.

    Definition id_left_adjoint_equivalence_to_pb_ump_2_cell
      : φ ==> ψ.
    Proof.
      use (pb_ump_cell H₂).
      - exact ((_ ◃ lpr1^-1) • α • (_ ◃ lpr1)).
      - exact ((_ ◃ lpr2^-1) • β • (_ ◃ lpr2)).
      - exact id_left_adjoint_equivalence_to_pb_ump_2_cell_eq.
    Defined.

    Definition id_left_adjoint_equivalence_to_pb_ump_2_cell_pr1
      : id_left_adjoint_equivalence_to_pb_ump_2_cell ▹ qpr1
        =
        α.
    Proof.
      unfold id_left_adjoint_equivalence_to_pb_ump_2_cell.
      use (vcomp_lcancel (φ ◃ lpr1 ^-1)).
      {
        is_iso.
      }
      use (vcomp_rcancel (ψ ◃ lpr1)).
      {
        is_iso.
        apply property_from_invertible_2cell.
      }
      rewrite <- vcomp_whisker.
      etrans.
      {
        do 2 apply maponpaths_2.
        apply (pb_ump_cell_pr1 H₂).
      }
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite lwhisker_id2.
      rewrite id2_right.
      apply idpath.
    Qed.

    Definition id_left_adjoint_equivalence_to_pb_ump_2_cell_pr2
      : id_left_adjoint_equivalence_to_pb_ump_2_cell ▹ qpr2
        =
        β.
    Proof.
      unfold id_left_adjoint_equivalence_to_pb_ump_2_cell.
      use (vcomp_lcancel (φ ◃ lpr2 ^-1)).
      {
        is_iso.
      }
      use (vcomp_rcancel (ψ ◃ lpr2)).
      {
        is_iso.
        apply property_from_invertible_2cell.
      }
      rewrite <- vcomp_whisker.
      etrans.
      {
        do 2 apply maponpaths_2.
        apply (pb_ump_cell_pr2 H₂).
      }
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite lwhisker_id2.
      rewrite id2_right.
      apply idpath.
    Qed.

    Definition id_left_adjoint_equivalence_to_pb_ump_2_unique
      : isaprop (∑ (γ : φ ==> ψ), γ ▹ qpr1 = α × γ ▹ qpr2 = β).
    Proof.
      use invproofirrelevance.
      intros ζ₁ ζ₂.
      use subtypePath.
      {
        intro.
        apply isapropdirprod ; apply cellset_property.
      }
      use (pb_ump_eq H₂) ; cbn.
      - exact ((_ ◃ lpr1^-1) • α • (_ ◃ lpr1)).
      - exact ((_ ◃ lpr2^-1) • β • (_ ◃ lpr2)).
      - exact id_left_adjoint_equivalence_to_pb_ump_2_cell_eq.
      - rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ].
        cbn.
        rewrite <- vcomp_whisker.
        apply maponpaths_2.
        exact (pr12 ζ₁).
      - rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ].
        cbn.
        rewrite <- vcomp_whisker.
        apply maponpaths_2.
        exact (pr22 ζ₁).
      - rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ].
        cbn.
        rewrite <- vcomp_whisker.
        apply maponpaths_2.
        exact (pr12 ζ₂).
      - rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ].
        cbn.
        rewrite <- vcomp_whisker.
        apply maponpaths_2.
        exact (pr22 ζ₂).
    Qed.
  End UMP2.

  Definition id_left_adjoint_equivalence_to_pb_ump_2
    : pb_ump_2 (make_pb_cone q qpr1 qpr2 qγ).
  Proof.
    intros qc φ ψ α β p.
    use iscontraprop1.
    - exact (id_left_adjoint_equivalence_to_pb_ump_2_unique _ _ p).
    - simple refine (_ ,, _ ,, _).
      + exact (id_left_adjoint_equivalence_to_pb_ump_2_cell _ _ p).
      + exact (id_left_adjoint_equivalence_to_pb_ump_2_cell_pr1 _ _ p).
      + exact (id_left_adjoint_equivalence_to_pb_ump_2_cell_pr2 _ _ p).
  Defined.

  Definition id_left_adjoint_equivalence_to_pb
    : has_pb_ump (make_pb_cone q qpr1 qpr2 qγ).
  Proof.
    split.
    - exact id_left_adjoint_equivalence_to_pb_ump_1.
    - exact id_left_adjoint_equivalence_to_pb_ump_2.
  Defined.
End IdEquivalenceToPB.

Definition left_adjoint_equivalence_eq_to_pb
           {B : bicat}
           {b₁ b₂ b₃ : B}
           {f : b₁ --> b₃}
           {g : b₂ --> b₃}
           (cone₁ cone₂ : pb_cone f g)
           (H₂ : has_pb_ump cone₂)
           (p : pr1 cone₁ = pr1 cone₂)
           (qp1 : invertible_2cell
                    (idtoiso_2_0 _ _ (!p) · pb_cone_pr1 cone₁)
                    (pb_cone_pr1 cone₂))
           (qp2 : invertible_2cell
                    (idtoiso_2_0 _ _ (!p) · pb_cone_pr2 cone₁)
                    (pb_cone_pr2 cone₂))
           (path : (qp1^-1 ▹ f)
                   • rassociator _ _ _
                   • (_ ◃ pb_cone_cell cone₁)
                   • lassociator _ _ _
                   • (qp2 ▹ g)
                   =
                   pr1 (pb_cone_cell cone₂))
  : has_pb_ump cone₁.
Proof.
  induction cone₁ as [ q cone ].
  induction cone as [ qp₁ cone ].
  induction cone as [ qp₂ γ ].
  induction cone₂ as [ q' cone ].
  induction cone as [ qp₁' cone ].
  induction cone as [ qp₂' γ' ].
  cbn in *.
  induction p ; cbn in *.
  use (id_left_adjoint_equivalence_to_pb _ _ H₂).
  - exact (comp_of_invertible_2cell (linvunitor_invertible_2cell _) qp1).
  - exact (comp_of_invertible_2cell (linvunitor_invertible_2cell _) qp2).
  - abstract
      (cbn ;
       use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn ;
       refine (_ @ path) ;
       rewrite <- !rwhisker_vcomp ;
       rewrite !vassocl ;
       apply maponpaths ;
       rewrite !vassocr ;
       apply maponpaths_2 ;
       use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
       rewrite !vassocl ;
       rewrite lunitor_triangle ;
       rewrite vcomp_lunitor ;
       rewrite !vassocr ;
       apply maponpaths_2 ;
       rewrite <- lunitor_triangle ;
       rewrite !vassocr ;
       rewrite rassociator_lassociator ;
       rewrite id2_left ;
       apply idpath).
Defined.

Section EquivalenceToPBHelp.
  Context {B : bicat}
          (HB_2_0 : is_univalent_2_0 B)
          {b₁ b₂ b₃ : B}
          {f : b₁ --> b₃}
          {g : b₂ --> b₃}
          (cone₁ cone₂ : pb_cone f g)
          (H₂ : has_pb_ump cone₂)
          (l : cone₁ --> cone₂)
          (Hl : left_adjoint_equivalence l)
          (r := left_adjoint_right_adjoint Hl)
          (rpr1 : invertible_2cell
                    (r · pb_cone_pr1 cone₁)
                    (pb_cone_pr1 cone₂))
          (rpr2 : invertible_2cell
                    (r · pb_cone_pr2 cone₁)
                    (pb_cone_pr2 cone₂))
          (path : (r ◃ pb_cone_cell cone₁) • lassociator _ _ _ • (rpr2 ▹ g)
                  =
                  lassociator _ _ _ • (rpr1 ▹ f) • pr1 (pb_cone_cell cone₂)).

  Local Definition help_inv2cell
    : invertible_2cell
        (idtoiso_2_0 _ _ (! isotoid_2_0 HB_2_0 (l,, Hl)))
        r.
  Proof.
    apply idtoiso_2_1.
    cbn.
    rewrite idtoiso_2_0_inv.
    rewrite idtoiso_2_0_isotoid_2_0.
    apply idpath.
  Qed.

  Definition left_adjoint_equivalence_to_pb_help_pr1
    : invertible_2cell
        (idtoiso_2_0 _ _ (! isotoid_2_0 HB_2_0 (l,, Hl))
         ·
         pb_cone_pr1 cone₁)
        (pb_cone_pr1 cone₂)
    := comp_of_invertible_2cell
         (rwhisker_of_invertible_2cell
            _
            help_inv2cell)
         rpr1.

  Definition left_adjoint_equivalence_to_pb_help_pr2
    : invertible_2cell
        (idtoiso_2_0 _ _ (! isotoid_2_0 HB_2_0 (l,, Hl))
         ·
         pb_cone_pr2 cone₁)
        (pb_cone_pr2 cone₂)
    := comp_of_invertible_2cell
         (rwhisker_of_invertible_2cell
            _
            help_inv2cell)
         rpr2.

  Definition left_adjoint_equivalence_to_pb_help_path
    : (left_adjoint_equivalence_to_pb_help_pr1^-1 ▹ f)
      • rassociator _ _ _
      • (_ ◃ pb_cone_cell cone₁)
      • lassociator _ _ _
      • (left_adjoint_equivalence_to_pb_help_pr2 ▹ g)
      =
      pr1 (pb_cone_cell cone₂).
  Proof.
    cbn.
    rewrite !vassocl.
    use vcomp_move_R_pM ; [ is_iso | ].
    cbn.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite <- rwhisker_rwhisker_alt.
    rewrite !vassocl.
    apply maponpaths.
    use vcomp_move_R_pM ; [ is_iso | ].
    rewrite !vassocr.
    exact path.
  Qed.

  Definition left_adjoint_equivalence_to_pb_help
    : has_pb_ump cone₁.
  Proof.
    use (left_adjoint_equivalence_eq_to_pb _ _ H₂).
    - exact (isotoid_2_0 HB_2_0 (l ,, Hl)).
    - exact left_adjoint_equivalence_to_pb_help_pr1.
    - exact left_adjoint_equivalence_to_pb_help_pr2.
    - exact left_adjoint_equivalence_to_pb_help_path.
  Defined.
End EquivalenceToPBHelp.

Section LeftAdjointEquivalenceToPB.
  Context {B : bicat}
          (HB_2_0 : is_univalent_2_0 B)
          {b₁ b₂ b₃ : B}
          {f : b₁ --> b₃}
          {g : b₂ --> b₃}
          (cone₁ cone₂ : pb_cone f g)
          (H₂ : has_pb_ump cone₂)
          (l : cone₁ --> cone₂)
          (Hl : left_adjoint_equivalence l)
          (lpr1 : invertible_2cell
                    (l · pb_cone_pr1 cone₂)
                    (pb_cone_pr1 cone₁))
          (lpr2 : invertible_2cell
                    (l · pb_cone_pr2 cone₂)
                    (pb_cone_pr2 cone₁))
          (path : (_ ◃ pb_cone_cell cone₂) • lassociator _ _ _ • (lpr2 ▹ g)
                  =
                  lassociator _ _ _ • (lpr1 ▹ f) • pb_cone_cell cone₁).

  Let r : cone₂ --> cone₁
    := left_adjoint_right_adjoint Hl.
  Let η : invertible_2cell (id₁ _) (l · r)
    := left_equivalence_unit_iso Hl.
  Let ε : invertible_2cell (r · l) (id₁ _)
    := left_equivalence_counit_iso Hl.

  Definition left_adjoint_equivalence_to_pb_pr1
    : invertible_2cell
        (r · pb_cone_pr1 cone₁)
        (pb_cone_pr1 cone₂)
    := comp_of_invertible_2cell
         (lwhisker_of_invertible_2cell
            _
            (inv_of_invertible_2cell lpr1))
         (comp_of_invertible_2cell
            (lassociator_invertible_2cell _ _ _)
            (comp_of_invertible_2cell
               (rwhisker_of_invertible_2cell _ ε)
               (lunitor_invertible_2cell _))).

  Definition left_adjoint_equivalence_to_pb_pr2
    : invertible_2cell
        (r · pb_cone_pr2 cone₁)
        (pb_cone_pr2 cone₂)
    := comp_of_invertible_2cell
         (lwhisker_of_invertible_2cell
            _
            (inv_of_invertible_2cell lpr2))
         (comp_of_invertible_2cell
            (lassociator_invertible_2cell _ _ _)
            (comp_of_invertible_2cell
               (rwhisker_of_invertible_2cell _ ε)
               (lunitor_invertible_2cell _))).

  Definition left_adjoint_equivalence_to_pb_eq
    : (r ◃ pb_cone_cell cone₁)
      • lassociator _ _ _
      • (left_adjoint_equivalence_to_pb_pr2 ▹ g)
      =
      lassociator _ _ _
      • (left_adjoint_equivalence_to_pb_pr1 ▹ f)
      • pr1 (pb_cone_cell cone₂).
  Proof.
    cbn.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker.
      rewrite !vassocl.
      apply idpath.
    }
    use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
    use (vcomp_lcancel (r ◃ lassociator _ _ _)) ; [ is_iso | ].
    rewrite !vassocr.
    rewrite lassociator_lassociator.
    rewrite !lwhisker_vcomp.
    rewrite <- path.
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      do 3 apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite rwhisker_vcomp.
        rewrite vcomp_rinv.
        rewrite id2_rwhisker.
        rewrite lwhisker_id2.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lassociator_lassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite lwhisker_lwhisker.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    rewrite <- vcomp_whisker.
    rewrite rwhisker_rwhisker.
    rewrite !vassocl.
    apply maponpaths.
    rewrite lunitor_triangle.
    rewrite vcomp_lunitor.
    rewrite !vassocr.
    rewrite lunitor_triangle.
    apply idpath.
  Qed.

  Definition left_adjoint_equivalence_to_pb
    : has_pb_ump cone₁.
  Proof.
    use (left_adjoint_equivalence_to_pb_help HB_2_0 _ _ H₂ l Hl).
    - exact left_adjoint_equivalence_to_pb_pr1.
    - exact left_adjoint_equivalence_to_pb_pr2.
    - exact left_adjoint_equivalence_to_pb_eq.
  Defined.
End LeftAdjointEquivalenceToPB.


Require Import Decidable.

(* Entscheidbarkeit auf Typenlevel*)
Definition decT (T : Type) : Type := T + ( T -> False).

Definition eq_dec (T : Type) : Type := forall (x y :T), decidable (x = y).
Eval compute in ( eq_dec nat).


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := nil : Lst | cons : Nat -> Lst -> Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint mem (mem_arg0 : Nat) (mem_arg1 : Lst) : Prop
:= match mem_arg0, mem_arg1 with
    | x, nil => False
    | x, cons y z => x = y \/ mem x z
    end.

Theorem theorem0 : forall (x : Nat) (y : Lst) (z : Lst), mem x z -> mem x (append y z).
Proof.
  intros.
  induction y.
  - auto.
  - simpl. auto.
Qed.


Require Import Arith Omega.
Require Import Word.
Require Import WordAuto.
Require Import Psatz.

(* TODO: move byte-specific lemmas *)
Require Import AsyncDisk.
Import Valulen.

(** The divup and roundup functions and associated theorems.
    divup n sz performs n / sz, rounding up rather than down.
    roundup n sz rounds n to the smallest multiple of sz >= n;
     it is similar to the customary n / sz * sz, but uses divup instead of /.
*)

Definition divup (n unitsz : nat) : nat := (n + unitsz - 1) / unitsz.
Definition roundup (n unitsz:nat) : nat := (divup n unitsz) * unitsz.

  Lemma div_le_mul : forall n a b,
    b > 0 -> a > 0 -> n / a <= n * b.
  Proof.
    intros.
    destruct n.
    destruct a; cbv; auto.
    destruct a; try omega.
    eapply le_trans.
    apply div_le; auto.
    rewrite Nat.mul_comm.
    destruct (mult_O_le (S n) b); auto; omega.
  Qed.

  Lemma mul_div : forall a b,
    a mod b = 0 ->
    b > 0 ->
    a / b * b = a.
  Proof.
    intros.
    erewrite Nat.div_mod with (x := a) (y := b) by omega.
    rewrite H, Nat.add_0_r.
    setoid_rewrite Nat.mul_comm at 2.
    rewrite Nat.div_mul by omega.
    setoid_rewrite Nat.mul_comm at 2; auto.
  Qed.

  Lemma mod_le_r : forall a b, a mod b <= b.
  Proof.
    intros. case_eq b; intros. auto.
    apply Nat.lt_le_incl, Nat.mod_upper_bound. omega.
  Qed.

  Lemma lt_add_lt_sub : forall a b c,
    b <= a -> a < b + c -> a - b < c.
  Proof.
    intros; omega.
  Qed.

  Lemma lt_div_mul_add_le : forall a b c,
    b > 0 -> a < c / b -> b + a * b <= c.
  Proof.
    intros.
    apply lt_le_S in H0.
    apply mult_le_compat_r with ( p := b ) in H0; auto.
    rewrite Nat.add_comm, <- Nat.mul_succ_l.
    eapply le_trans; eauto.
    rewrite Nat.mul_comm.
    apply Nat.mul_div_le; omega.
  Qed.

  Lemma lt_div_mul_lt : forall a b c,
    b > 0 -> a < c / b -> a * b < c.
  Proof.
    intros.
    apply lt_div_mul_add_le in H0; auto; omega.
  Qed.

  Lemma div_lt_mul_lt : forall a b c,
    b > 0 -> a / b < c -> a < c * b.
  Proof.
    intros.
    apply lt_le_S in H0.
    apply mult_le_compat_r with ( p := b ) in H0; auto.
    eapply lt_le_trans; [ | eauto ].
    rewrite Nat.mul_comm.
    apply Nat.mul_succ_div_gt; omega.
  Qed.

  Lemma sub_round_eq_mod : forall a b, b <> 0 -> a - a / b * b = a mod b.
  Proof.
    intros.
    rewrite Nat.mod_eq, mult_comm; auto.
  Qed.

  Lemma mult_neq_0 : forall m n, m <> 0 -> n <> 0 -> m * n <> 0.
  Proof.
    intros. intuition.
  Qed.

  Lemma mul_ge_l : forall m n,
    0 < m -> n <= n * m.
  Proof.
    intros.
    rewrite mult_comm.
    destruct (mult_O_le n m); solve [ omega | auto].
  Qed.

  Lemma mul_ge_r : forall m n,
    0 < m -> n <= m * n.
  Proof.
    intros. rewrite mult_comm. apply mul_ge_l; auto.
  Qed.

  Lemma div_mul_le : forall a b : addr, a / b * b <= a.
  Proof.
    intros.
    destruct (Nat.eq_dec b 0) as [H|H]; subst; try omega.
    pose proof Nat.div_mod a b H.
    rewrite mult_comm; omega.
  Qed.

  Lemma sub_sub_assoc : forall a b,
    a >= b -> a - (a - b) = b.
  Proof.
    intros; omega.
  Qed.

  Lemma sub_mod_eq_round : forall a b, b <> 0 -> a - (a mod b) = a / b * b.
  Proof.
    intros.
    rewrite <- sub_round_eq_mod at 1 by auto.
    rewrite sub_sub_assoc; auto.
    apply div_mul_le.
  Qed.

  Lemma roundup_ge: forall x sz,
      sz > 0 ->
      roundup x sz >= x.
  Proof.
    unfold roundup, divup; intros.
    rewrite (Nat.div_mod x sz) at 1 by omega.
    rewrite <- Nat.add_sub_assoc by omega.
    rewrite <- plus_assoc.
    rewrite (mult_comm sz).
    rewrite Nat.div_add_l by omega.

    case_eq (x mod sz); intros.
    - rewrite (Nat.div_mod x sz) at 2 by omega.
       nia.

    - rewrite Nat.mul_add_distr_r.
      replace (S n + (sz - 1)) with (sz + n) by omega.
      replace (sz) with (1 * sz) at 3 by omega.
      rewrite Nat.div_add_l by omega.
      rewrite (Nat.div_mod x sz) at 2 by omega.
      assert (x mod sz < sz).
      apply Nat.mod_bound_pos; omega.
      nia.
  Qed.

  Lemma roundup_ge_divisor : forall x sz, 0 < x -> roundup x sz >= sz.
  Proof.
    unfold roundup; intros.
    case_eq sz; intros; subst; auto.
    unfold ge.
    rewrite <- mult_1_l at 1.
    apply mult_le_compat; auto.
    unfold divup.
    apply Nat.div_str_pos; omega.
  Qed.

  Lemma divup_ok:
    forall x,
      divup x valubytes * valubytes >= x.
  Proof.
    intros.
    apply roundup_ge.
    rewrite valubytes_is; omega.
  Qed.

  Lemma divup_0:
    forall x,
    divup 0 x = 0.
  Proof.
    intros.
    case_eq x; intros.
    reflexivity.
    apply Nat.div_small.
    omega.
  Qed.

  Lemma roundup_0:
    forall x,
    roundup 0 x = 0.
  Proof.
    unfold roundup; intros.
    rewrite divup_0. auto.
  Qed.

  Lemma divup_1: forall x,
    divup x 1 = x.
  Proof.
    simpl; intros.
    replace (x + 1 - 1) with x by omega.
    pose proof (Nat.divmod_spec x 0 0 0 (Nat.le_refl 0)).
    destruct (Nat.divmod x 0 0 0); simpl.
    omega.
  Qed.

  Lemma divup_divup_eq:
    forall x,
      (divup ((divup x valubytes)*valubytes) valubytes) * valubytes =
      (divup x valubytes) * valubytes.
  Proof.
    unfold divup; intros.
    rewrite <- Nat.add_sub_assoc by ( rewrite valubytes_is; omega ).
    rewrite Nat.div_add_l by ( rewrite valubytes_is; omega ).
    rewrite Nat.mul_add_distr_r.
    replace ((valubytes - 1) / valubytes * valubytes) with 0. omega.
    rewrite valubytes_is.
    compute.
    auto.
  Qed.

  Lemma divup_lt_arg: forall x sz,
    divup x sz <= x.
  Proof.
    intros.
    case_eq sz; intros.
    (* sz = 0 *)
    simpl. omega.
    case_eq x; intros.
    (* x = 0 *)
    rewrite divup_0; constructor.
    unfold divup.
    (* sz > 0, x > 0 *)
    rewrite Nat.div_mod with (y := S n) by omega.
    rewrite <- H.
    rewrite <- H0.
    apply le_trans with (sz * x / sz).
    apply Nat.div_le_mono.
    omega.
    replace (sz) with (1 + (sz - 1)) at 2 by omega.
    rewrite Nat.mul_add_distr_r.
    rewrite Nat.mul_1_l.
    replace (x + sz - 1) with (x + (sz - 1)).
    apply plus_le_compat_l.
    replace x with (n0 + 1) by omega.
    rewrite Nat.mul_add_distr_l.
    rewrite plus_comm.
    rewrite Nat.mul_1_r.
    apply le_plus_l.
    omega.
    rewrite mult_comm.
    rewrite Nat.div_mul by omega.
    apply Nat.eq_le_incl.
    apply Nat.div_mod.
    omega.
  Qed.

  Lemma divup_ge : forall a b c,
    b > 0 ->
    c >= divup a b -> c * b >= a.
  Proof.
    intros.
    apply le_trans with (m := divup a b * b).
    apply roundup_ge; auto.
    apply Nat.mul_le_mono_pos_r; auto.
  Qed.

  Lemma divup_mono: forall m n sz,
    m <= n -> divup m sz <= divup n sz.
  Proof.
    intros.
    case_eq sz; intros.
    reflexivity.
    apply Nat.div_le_mono.
    auto.
    omega.
  Qed.

  Lemma roundup_mono : forall m n sz,
    m <= n -> roundup m sz <= roundup n sz.
  Proof.
    intros.
    unfold roundup.
    apply Nat.mul_le_mono_nonneg_r.
    omega.
    apply divup_mono; assumption.
  Qed.

  Definition divup' x m :=
  match (x mod m) with
  | O => x / m
  | S _ => x / m + 1
  end.

  Theorem divup_eq_divup'_m_nonzero : forall x m,
    m <> 0 ->
    divup x m = divup' x m.
  Proof.
    intros.
    unfold divup, divup'.
    case_eq (x mod m); intros.
    assert (Hxm := Nat.div_mod x m H).
    rewrite H0 in Hxm.
    symmetry.
    apply Nat.div_unique with (m - 1).
    omega.
    omega.
    assert (Hxm := Nat.div_mod x m H).
    symmetry.
    apply Nat.div_unique with (r := x mod m - 1).
    apply lt_trans with (x mod m).
    omega.
    apply Nat.mod_upper_bound; assumption.
    replace (x + m - 1) with (x + (m - 1)) by omega.
    rewrite Hxm at 1.
    rewrite Nat.mul_add_distr_l.
    rewrite Nat.mul_1_r.
    assert (x mod m + (m - 1) = m + (x mod m - 1)).
    omega.
    omega.
  Qed.

  Theorem divup_eq_divup' : forall x m,
    divup x m = divup' x m.
  Proof.
    intros.
    case_eq m; intros.
    unfold divup, divup'.
    reflexivity.
    apply divup_eq_divup'_m_nonzero.
    omega.
  Qed.

  Ltac divup_cases :=
    rewrite divup_eq_divup';
    match goal with
    | [ |- context[divup' ?x ?m] ] =>
      unfold divup';
      case_eq (x mod m); intros
    end.

  Lemma divup_mul : forall x m,
    m <> 0 ->
    divup (x*m) m = x.
  Proof.
    intros.
    rewrite divup_eq_divup'.
    unfold divup'.
    rewrite Nat.mod_mul by assumption.
    apply Nat.div_mul.
    assumption.
  Qed.

  Lemma divup_eq_div : forall a b, a mod b = 0 -> divup a b = a / b.
  Proof.
    intros.
    rewrite divup_eq_divup'. unfold divup'.
    destruct (a mod b); omega.
  Qed.

  Lemma div_le_divup : forall n sz,
    n / sz <= divup n sz.
  Proof.
    intros.
    destruct sz.
    - simpl.
      omega.
    - unfold divup.
      apply Nat.div_le_mono.
      omega.
      omega.
  Qed.

  Lemma div_lt_divup : forall m n sz,
    sz <> 0 ->
    m < n ->
    m / sz < divup n sz.
  Proof.
    intros.
    rewrite divup_eq_divup'.
    unfold divup'.
    case_eq (n mod sz); intros.
    rewrite Nat.mul_lt_mono_pos_l with (p := sz) by omega.
    replace (sz * (n / sz)) with n.
    eapply le_lt_trans.
    apply Nat.mul_div_le.
    omega.
    assumption.
    apply Nat.div_exact; assumption.
    apply le_lt_trans with (n / sz).
    apply Nat.div_le_mono; omega.
    omega.
  Qed.

  Lemma le_divup:
    forall m n,
      m <= n ->
      divup m valubytes <= divup n valubytes.
  Proof.
    intros.
    apply divup_mono; assumption.
  Qed.

  Lemma le_roundup:
    forall m n,
      m <= n ->
      roundup m valubytes <= roundup n valubytes.
  Proof.
    unfold roundup, divup; intros.
    apply Nat.mul_le_mono_r.
    apply le_divup; assumption.
  Qed.

  (* slightly different from the one in Word.v *)
  Lemma lt_minus':
    forall a b c,
      a < c -> a - b < c.
  Proof.
    intros.
    omega.
  Qed.

  Lemma divup_goodSize:
    forall (a: waddr),
      goodSize addrlen (divup #a valubytes).
  Proof.
    assert (addrlen > 1) by ( unfold addrlen ; omega ).
    generalize dependent addrlen.
    intros.
    unfold goodSize, divup.
    apply Nat.div_lt_upper_bound.
    rewrite valubytes_is; simpl valubytes_real; auto.
    apply lt_minus'.
    unfold addrlen.
    rewrite valubytes_is; simpl valubytes_real.
    replace (4096) with (pow2 12) by reflexivity.
    rewrite <- pow2_add_mul.
    replace (pow2 (12 + n)) with (pow2 (11 + n) + pow2 (11 + n)).
    apply plus_lt_compat.
    eapply lt_trans.
    apply natToWord_goodSize.
    apply pow2_inc; omega.
    apply pow2_inc; omega.
    replace (12 + n) with ((11 + n) + 1) by omega.
    rewrite (pow2_add_mul (11+n) 1).
    simpl (pow2 1).
    omega.
  Qed.

  Lemma divup_sub_1 : forall n sz,
    n >= sz -> sz <> 0 ->
    divup (n - sz) sz = divup n sz - 1.
  Proof.
    unfold divup; intros; simpl.
    replace (n - sz + sz) with n by lia.
    replace (n + sz - 1) with (n - 1 + 1 * sz) by lia.
    rewrite Nat.div_add by auto.
    omega.
  Qed.

  Lemma divup_sub : forall i n sz,
    n >= i * sz -> sz <> 0 ->
    divup (n - i * sz) sz = divup n sz - i.
  Proof.
    induction i; intros; simpl.
    repeat rewrite Nat.sub_0_r; auto.
    replace (n - (sz + i * sz)) with ((n - sz) - (i * sz)) by nia.
    rewrite IHi by nia.
    rewrite divup_sub_1; nia.
  Qed.

  Lemma sub_mod_add_mod : forall a b,
    b <> 0 -> b - a mod b + a mod b = b.
  Proof.
    intros.
    pose proof (Nat.mod_upper_bound a b H).
    omega.
  Qed.

  Lemma divup_mul_l : forall b c,
    divup (c * b) b <= c.
  Proof.
    intros; destruct (Nat.eq_dec b 0); subst.
    rewrite Nat.mul_0_r; rewrite divup_0; omega.
    rewrite divup_mul; omega.
  Qed.

  Lemma divup_mul_r : forall b c,
    divup (b * c) b <= c.
  Proof.
    intros; rewrite Nat.mul_comm; apply divup_mul_l.
  Qed.

  Lemma divup_le : forall a b c,
    a <= b * c -> divup a b <= c.
  Proof.
    intros.
    eapply le_trans.
    apply divup_mono; eauto.
    rewrite divup_mul_r; auto.
  Qed.

  Lemma divup_le_1 : forall a b,
    a <= b -> divup a b <= 1.
  Proof.
    intros; apply divup_le; omega.
  Qed.

  Lemma divup_ge_1 : forall a b,
   b <> 0 -> a >= b -> divup a b >= 1.
  Proof.
    intros; unfold divup.
    replace (a + b - 1) with (a - 1 + 1 * b) by omega.
    rewrite Nat.div_add by auto.
    nia.
  Qed.

  Lemma divup_small : forall c n, 0 < c <= n -> divup c n = 1.
  Proof.
    intros.
    assert (divup c n <= 1) by (apply divup_le_1; omega).
    assert (c - 1 < n) by omega.
    assert ((c - 1) / n < divup c n) by (apply div_lt_divup; omega).
    assert ((c - 1) / n = 0) as HH by (apply Nat.div_small; auto); rewrite HH in *.
    omega.
  Qed.

  Lemma divup_mul_ge : forall a b c,
    b <> 0 -> a >= b * c -> divup a b >= c.
  Proof.
    intros.
    eapply le_trans.
    2: apply divup_mono; eauto.
    rewrite Nat.mul_comm.
    rewrite divup_mul; auto.
  Qed.

  Lemma divup_gt_0 : forall a b, 0 < a -> 0 < b -> divup a b > 0.
  Proof.
    intros.
    apply Nat.div_str_pos; omega.
  Qed.

  Lemma mod_div_0 : forall a b,
    (a mod b) / b = 0.
  Proof.
    intros.
    destruct (Nat.eq_dec b 0); subst; simpl; auto.
    rewrite Nat.div_small; auto.
    apply Nat.mod_bound_pos; omega.
  Qed.

  Lemma div_add_distr_le : forall a b c,
    a / c + b / c <= (a + b) / c.
  Proof.
    intros.
    destruct (Nat.eq_dec c 0); subst; simpl; auto.
    rewrite Nat.div_mod with (x := a) (y := c) by auto.
    rewrite Nat.div_mod with (x := b) (y := c) by auto.
    replace (c * (a / c) + a mod c + (c * (b / c) + b mod c)) with
            (((a mod c + b mod c) + (b / c) * c) + (a / c) * c) by nia.
    repeat rewrite Nat.div_add by auto.
    setoid_rewrite Nat.add_comm at 2 3.
    setoid_rewrite Nat.mul_comm.
    repeat rewrite Nat.div_add by auto.
    repeat rewrite mod_div_0.
    repeat rewrite Nat.add_0_l.
    omega.
  Qed.

  Lemma divup_add' : forall i n sz,
    sz <> 0 -> n <> 0 ->
    divup (n + sz * i) sz = divup n sz + i.
  Proof.
    induction i; intros; simpl.
    rewrite Nat.add_0_r; rewrite Nat.mul_0_r; auto.
    replace (n + (sz * S i)) with ((n + sz) + (sz * i)) by nia.
    rewrite IHi by nia.
    unfold divup.
    replace (n + sz + sz - 1) with (n - 1 + 2 * sz) by nia.
    replace (n + sz - 1) with (n - 1 + 1 * sz) by nia.
    repeat rewrite Nat.div_add by auto.
    omega.
  Qed.

  Lemma divup_add : forall i n sz,
    sz <> 0 -> divup (n + sz * i) sz = divup n sz + i.
  Proof.
    intros.
    destruct (Nat.eq_dec n 0); subst.
    rewrite divup_0; rewrite Nat.add_0_l; rewrite Nat.mul_comm.
    rewrite divup_mul; omega.
    apply divup_add'; auto.
  Qed.

  Lemma divup_n_mul_n_le : forall a n, n <> 0 -> a <= (divup a n) * n.
  Proof.
    intros.
    destruct (addr_eq_dec a 0); subst; try lia.
    eapply (Nat.div_mod a) in H as HH.
    rewrite HH.
    rewrite plus_comm.
    rewrite divup_add by omega.
    rewrite Nat.mul_add_distr_r.
    destruct (addr_eq_dec (a mod n) 0) as [H'|H'].
    rewrite H'.
    rewrite mul_div; lia.
    rewrite divup_small.
    simpl. rewrite plus_0_r.
    pose proof Nat.mod_upper_bound a n H.
    rewrite mult_comm; omega.
    split. omega.
    apply Nat.lt_le_incl. apply Nat.mod_upper_bound.
    omega.
  Qed.

  Lemma add_lt_upper_bound : forall a b c d,
    a <= b -> c + b < d -> c + a < d.
  Proof.
    intros; omega.
  Qed.

  Lemma helper_sub_add_cancel : forall a b c,
    a >= b -> b >= c ->
    a - b + (b - c) = a - c.
  Proof.
    intros; omega.
  Qed.

  Lemma helper_add_sub_lt : forall a b c,
    b > 0 -> a < c -> a + b - c < b.
  Proof.
    intros. omega.
  Qed.

  Lemma div_mul_lt : forall a b,
    b <> 0 -> a mod b <> 0 -> a / b * b < a.
  Proof.
    intros.
    rewrite Nat.div_mod with (x := a) (y := b) by auto.
    setoid_rewrite Nat.mul_comm at 2.
    repeat rewrite Nat.div_add_l by omega.
    rewrite Nat.div_small with (a := (a mod b)).
    rewrite Nat.add_0_r, Nat.mul_comm.
    omega.
    apply Nat.mod_upper_bound; omega.
  Qed.

  Theorem roundup_mult_mono : forall n a b, b <> 0 ->
    Nat.divide a b -> roundup n a <= roundup n b.
  Proof.
    intros.
    unfold Nat.divide in *.
    destruct H0; subst.
    destruct (addr_eq_dec x 0) as [|Hx]; subst; try omega.
    destruct (addr_eq_dec n 0) as [|Hn]; subst.
    repeat rewrite roundup_0; auto.
    destruct (addr_eq_dec a 0) as [|Ha]; subst; [> rewrite mult_comm; auto |].
    unfold roundup.
    rewrite mult_assoc.
    apply mult_le_compat_r.
    unfold divup.
    replace (n + a - 1) with ((1 * a) + (n - 1)) by omega.
    replace (n + x * a - 1) with (1 * (x * a) + (n - 1)) by lia.
    repeat rewrite Nat.div_add_l by auto.
    replace (x * a) with (a * x) by (apply mult_comm).
    rewrite <- Nat.div_div by auto.
    remember ((n - 1) / a) as r.
    apply Nat.div_mod with (x := r) in Hx as Hr.
    rewrite plus_comm in Hr.
    rewrite Hr at 1.
    rewrite plus_assoc, mult_comm.
    apply plus_le_compat_r.
    eapply lt_le_trans; [> apply Nat.mod_upper_bound | ]; auto.
  Qed.

  Lemma min_roundup : forall a b z, roundup (min a b) z = min (roundup a z) (roundup b z).
  Proof.
    intros.
    edestruct Min.min_spec as [ [HH Hmin]|[HH Hmin] ]; rewrite Hmin in *;
    symmetry; (apply min_l || apply min_r);
    apply roundup_mono; omega.
  Qed.

  Lemma roundup_mult : forall a b, roundup (a * b) a = a * b.
  Proof.
    unfold roundup; intros.
    destruct (Nat.eq_dec a 0); subst; simpl; auto.
    replace (a * b) with (b * a) by apply mult_comm.
    destruct (Nat.eq_dec b 0); subst; simpl.
    rewrite divup_0; auto.
    rewrite divup_mul; auto.
  Qed.

  Lemma roundup_sub_lt : forall n sz,
    sz > 0 -> roundup n sz - n < sz.
  Proof.
    unfold roundup; intros.
    divup_cases.
    replace (n / sz * sz) with n; try omega.
    rewrite Nat.mul_comm.
    rewrite Nat.div_exact; omega.
    rewrite Nat.mul_add_distr_r, Nat.mul_1_l.

    apply helper_add_sub_lt; auto.
    apply div_mul_lt; omega.
  Qed.

  Lemma roundup_subt_divide : forall a b c, a < roundup b c -> Nat.divide c a ->
    roundup (b - a) c = roundup b c - a.
  Proof.
    intros.
    destruct H0 as [x H0].
    destruct (Nat.eq_dec c 0); subst; unfold roundup; auto.
    rewrite divup_sub; auto.
    rewrite Nat.mul_sub_distr_r; auto.
    unfold roundup in *.
    rewrite <- Nat.mul_lt_mono_pos_r in H by omega.
    unfold ge.
    unfold divup in *.
    apply lt_div_mul_add_le in H; omega.
  Qed.

  Lemma divup_add_small : forall m n k,
    k > 0 -> n <= roundup m k - m ->
    divup (m + n) k = divup m k.
  Proof.
    unfold roundup, divup; intros.
    replace (m + n + k - 1) with ((m + k - 1) + n) by omega.
    rewrite Nat.div_mod with (x := (m + k -1)) (y := k) by omega.
    rewrite Nat.mul_comm.
    rewrite <- Nat.add_assoc.
    repeat rewrite Nat.div_add_l by omega.
    f_equal.
    repeat rewrite Nat.div_small; auto.
    apply Nat.mod_upper_bound; omega.

    eapply add_lt_upper_bound; eauto.
    rewrite Nat.mod_eq by omega.
    rewrite Nat.mul_comm.

    destruct (le_gt_dec (m + k - 1) ((m + k - 1) / k * k)).
    replace (m + k - 1 - (m + k - 1) / k * k ) with 0 by omega.
    rewrite Nat.add_0_l.

    apply roundup_sub_lt; auto.
    rewrite helper_sub_add_cancel; try omega.
    apply roundup_ge; auto.
  Qed.

  Lemma divup_divup: forall x sz,
      sz > 0 ->
      divup ((divup x sz) * sz) sz = divup x sz.
  Proof.
    unfold divup; intros.
    rewrite <- Nat.add_sub_assoc by omega.
    rewrite Nat.div_add_l by omega.
    replace ((sz - 1) / sz) with 0. omega.
    rewrite Nat.div_small; omega.
  Qed.

  Lemma roundup_roundup : forall n sz,
    sz > 0 ->
    roundup (roundup n sz) sz = roundup n sz.
  Proof.
    unfold roundup; intros.
    rewrite divup_divup; auto.
  Qed.

  Lemma roundup_roundup_add : forall x n sz,
    sz > 0 ->
    roundup (roundup n sz + x) sz = roundup n sz + roundup x sz.
  Proof.
    unfold roundup; intros.
    rewrite Nat.add_comm.
    setoid_rewrite Nat.mul_comm at 2.
    rewrite divup_add by omega.
    lia.
  Qed.

  Lemma divup_same : forall x,
    x <> 0 -> divup x x = 1.
  Proof.
    intros; erewrite <- divup_mul; eauto.
    rewrite Nat.mul_1_l; auto.
  Qed.

  Lemma divup_gt : forall a b sz,
    sz > 0 -> divup a sz > b -> a > b * sz.
  Proof.
    intros a b sz H.
    divup_cases.
    eapply Nat.mul_lt_mono_pos_r in H1; eauto.
    replace (a / sz * sz) with a in H1; auto.
    rewrite Nat.mul_comm.
    apply Nat.div_exact; omega.

    destruct b.
    destruct (Nat.eq_dec a 0); subst.
    contradict H0.
    rewrite Nat.mod_0_l; omega.
    omega.

    rewrite Nat.add_1_r in H1.
    apply lt_n_Sm_le in H1.
    eapply Nat.mul_le_mono_pos_r in H1; eauto.
    replace (a / sz * sz) with (a - a mod sz) in H1.
    rewrite H0 in H1.
    eapply Nat.le_lt_trans; eauto.
    destruct (Nat.eq_dec a 0); subst.
    contradict H0.
    rewrite Nat.mod_0_l; omega.
    omega.

    rewrite Nat.mod_eq by omega.
    setoid_rewrite Nat.mul_comm at 2.
    apply sub_sub_assoc.
    apply Nat.mul_div_le; omega.
  Qed.

  Definition divup_S x sz :=
    match (x mod sz) with
    | O => divup x sz + 1
    | S _ => divup x sz
    end.

  Theorem divup_eq_divup_S : forall x sz,
    sz <> 0 ->
    divup (S x) sz = divup_S x sz.
  Proof.
    intros.
    unfold divup, divup_S.
    divup_cases;
    replace (S x + sz - 1) with (x + 1 * sz) by omega;
    rewrite Nat.div_add; auto.
  Qed.

  Lemma divup_add_gt : forall a b n sz,
    sz > 0 -> a + divup b sz > n ->
    a * sz + b > n * sz.
  Proof.
    induction a; intros; auto.
    rewrite Nat.add_0_l in H0.
    rewrite Nat.add_0_l.
    apply divup_gt; auto.

    replace (S a * sz + b) with (a * sz + (b + sz * 1)).
    apply IHa; auto.
    rewrite divup_add; omega.
    rewrite Nat.mul_1_r.
    rewrite Nat.mul_succ_l.
    omega.
  Qed.

  Lemma roundup_le' : forall a b sz,
    sz > 0 ->
    a <= b * sz -> roundup a sz <= b * sz.
  Proof.
    intros.
    apply (roundup_mono _ _ sz) in H0.
    eapply le_trans; eauto.
    unfold roundup.
    apply Nat.mul_le_mono_pos_r; auto.
    apply divup_mul_l.
  Qed.

  Lemma roundup_le : forall a b sz,
    a <= b * sz -> roundup a sz <= b * sz.
  Proof.
    destruct sz; intros.
    unfold roundup.
    repeat rewrite Nat.mul_0_r; auto.
    apply roundup_le'; auto; omega.
  Qed.

  Lemma roundup_min_r : forall a b,
    b > 0 -> Nat.min ((divup a b) * b ) a = a.
  Proof.
    intros.
    apply Nat.min_r.
    apply roundup_ge; auto.
  Qed.

  Lemma divup_eq_div_plus_1 : forall a b, a mod b <> 0 -> divup a b = a / b + 1.
  Proof.
    intros.
    divup_cases; omega.
  Qed.

  Lemma roundup_gt : forall a b, b <> 0 -> a mod b <> 0 -> a < roundup a b.
  Proof.
    intros.
    unfold roundup.
    rewrite divup_eq_div_plus_1 by auto.
    rewrite Nat.mul_add_distr_r. rewrite mult_1_l.
    rewrite Nat.div_mod with (x := a) (y := b) at 1 by auto.
    rewrite mult_comm.
    assert (a mod b < b) by (apply Nat.mod_upper_bound; auto). omega.
  Qed.

  Lemma roundup_eq : forall a n, n <> 0 -> a mod n <> 0 -> roundup a n = a + (n - a mod n).
  Proof.
    intros.
    unfold roundup.
    rewrite divup_eq_divup'. unfold divup'.
    destruct (a mod n) as [|n'] eqn:HH; intuition.
    replace (S n') with (a mod n) by omega.
    rewrite Nat.div_mod with (x := a) (y := n) at 2 by auto.
    rewrite <- plus_assoc.
    rewrite <- le_plus_minus by (apply mod_le_r).
    rewrite Nat.mul_add_distr_r. rewrite mult_comm. omega.
  Qed.