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

(***********************************************************)
(** * Binary Integers *)
(** Initial author: Pierre Crégut, CNET, Lannion, France *)
(***********************************************************)

Require Export BinPos Pnat.
Require Import BinNat Plus Mult.

Inductive Z : Set :=
  | Z0 : Z
  | Zpos : positive -> Z
  | Zneg : positive -> Z.

(** Automatically open scope positive_scope for the constructors of Z *)
Delimit Scope Z_scope with Z.
Bind Scope Z_scope with Z.
Arguments Scope Zpos [positive_scope].
Arguments Scope Zneg [positive_scope].

(*************************************)
(** * Basic operations *)

(** ** Subtraction of positive into Z *)

Definition Zdouble_plus_one (x:Z) :=
  match x with
    | Z0 => Zpos 1
    | Zpos p => Zpos p~1
    | Zneg p => Zneg (Pdouble_minus_one p)
  end.

Definition Zdouble_minus_one (x:Z) :=
  match x with
    | Z0 => Zneg 1
    | Zneg p => Zneg p~1
    | Zpos p => Zpos (Pdouble_minus_one p)
  end.

Definition Zdouble (x:Z) :=
  match x with
    | Z0 => Z0
    | Zpos p => Zpos p~0
    | Zneg p => Zneg p~0
  end.

Open Local Scope positive_scope.

Fixpoint ZPminus (x y:positive) {struct y} : Z :=
  match x, y with
    | p~1, q~1 => Zdouble (ZPminus p q)
    | p~1, q~0 => Zdouble_plus_one (ZPminus p q)
    | p~1, 1 => Zpos p~0
    | p~0, q~1 => Zdouble_minus_one (ZPminus p q)
    | p~0, q~0 => Zdouble (ZPminus p q)
    | p~0, 1 => Zpos (Pdouble_minus_one p)
    | 1, q~1 => Zneg q~0
    | 1, q~0 => Zneg (Pdouble_minus_one q)
    | 1, 1 => Z0
  end.

Close Local Scope positive_scope.

(** ** Addition on integers *)

Definition Zplus (x y:Z) :=
  match x, y with
    | Z0, y => y
    | Zpos x', Z0 => Zpos x'
    | Zneg x', Z0 => Zneg x'
    | Zpos x', Zpos y' => Zpos (x' + y')
    | Zpos x', Zneg y' =>
      match (x' ?= y')%positive Eq with
	| Eq => Z0
	| Lt => Zneg (y' - x')
	| Gt => Zpos (x' - y')
      end
    | Zneg x', Zpos y' =>
      match (x' ?= y')%positive Eq with
	| Eq => Z0
	| Lt => Zpos (y' - x')
	| Gt => Zneg (x' - y')
      end
    | Zneg x', Zneg y' => Zneg (x' + y')
  end.

Infix "+" := Zplus : Z_scope.

(** ** Opposite *)

Definition Zopp (x:Z) :=
  match x with
    | Z0 => Z0
    | Zpos x => Zneg x
    | Zneg x => Zpos x
  end.

Notation "- x" := (Zopp x) : Z_scope.

(** ** Successor on integers *)

Definition Zsucc (x:Z) := (x + Zpos 1)%Z.

(** ** Predecessor on integers *)

Definition Zpred (x:Z) := (x + Zneg 1)%Z.

(** ** Subtraction on integers *)

Definition Zminus (m n:Z) := (m + - n)%Z.

Infix "-" := Zminus : Z_scope.

(** ** Multiplication on integers *)

Definition Zmult (x y:Z) :=
  match x, y with
    | Z0, _ => Z0
    | _, Z0 => Z0
    | Zpos x', Zpos y' => Zpos (x' * y')
    | Zpos x', Zneg y' => Zneg (x' * y')
    | Zneg x', Zpos y' => Zneg (x' * y')
    | Zneg x', Zneg y' => Zpos (x' * y')
  end.

Infix "*" := Zmult : Z_scope.

(** ** Comparison of integers *)

Definition Zcompare (x y:Z) :=
  match x, y with
    | Z0, Z0 => Eq
    | Z0, Zpos y' => Lt
    | Z0, Zneg y' => Gt
    | Zpos x', Z0 => Gt
    | Zpos x', Zpos y' => (x' ?= y')%positive Eq
    | Zpos x', Zneg y' => Gt
    | Zneg x', Z0 => Lt
    | Zneg x', Zpos y' => Lt
    | Zneg x', Zneg y' => CompOpp ((x' ?= y')%positive Eq)
  end.

Infix "?=" := Zcompare (at level 70, no associativity) : Z_scope.

Ltac elim_compare com1 com2 :=
  case (Dcompare (com1 ?= com2)%Z);
    [ idtac | let x := fresh "H" in
      (intro x; case x; clear x) ].

(** ** Sign function *)

Definition Zsgn (z:Z) : Z :=
  match z with
    | Z0 => Z0
    | Zpos p => Zpos 1
    | Zneg p => Zneg 1
  end.

(** ** Direct, easier to handle variants of successor and addition *)

Definition Zsucc' (x:Z) :=
  match x with
    | Z0 => Zpos 1
    | Zpos x' => Zpos (Psucc x')
    | Zneg x' => ZPminus 1 x'
  end.

Definition Zpred' (x:Z) :=
  match x with
    | Z0 => Zneg 1
    | Zpos x' => ZPminus x' 1
    | Zneg x' => Zneg (Psucc x')
  end.

Definition Zplus' (x y:Z) :=
  match x, y with
    | Z0, y => y
    | x, Z0 => x
    | Zpos x', Zpos y' => Zpos (x' + y')
    | Zpos x', Zneg y' => ZPminus x' y'
    | Zneg x', Zpos y' => ZPminus y' x'
    | Zneg x', Zneg y' => Zneg (x' + y')
  end.

Open Local Scope Z_scope.

(**********************************************************************)
(** ** Inductive specification of Z *)

Theorem Zind :
  forall P:Z -> Prop,
    P Z0 ->
    (forall x:Z, P x -> P (Zsucc' x)) ->
    (forall x:Z, P x -> P (Zpred' x)) -> forall n:Z, P n.
Proof.
  intros P H0 Hs Hp z; destruct z.
  assumption.
  apply Pind with (P := fun p => P (Zpos p)).
    change (P (Zsucc' Z0)); apply Hs; apply H0.
    intro n; exact (Hs (Zpos n)).
  apply Pind with (P := fun p => P (Zneg p)).
    change (P (Zpred' Z0)); apply Hp; apply H0.
    intro n; exact (Hp (Zneg n)).
Qed.

(**********************************************************************)
(** * Misc properties about binary integer operations *)

(**********************************************************************)
(** ** Properties of opposite on binary integer numbers *)

Theorem Zopp_0 : Zopp Z0 = Z0.
Proof.
  reflexivity.
Qed.

Theorem Zopp_neg : forall p:positive, - Zneg p = Zpos p.
Proof.
  reflexivity.
Qed.

(** [opp] is involutive *)

Theorem Zopp_involutive : forall n:Z, - - n = n.
Proof.
  intro x; destruct x; reflexivity.
Qed.

(** Injectivity of the opposite *)

Theorem Zopp_inj : forall n m:Z, - n = - m -> n = m.
Proof.
  intros x y; case x; case y; simpl; intros;
    [ trivial
      | discriminate H
      | discriminate H
      | discriminate H
      | simplify_eq H; intro E; rewrite E; trivial
      | discriminate H
      | discriminate H
      | discriminate H
      | simplify_eq H; intro E; rewrite E; trivial ].
Qed.

(**********************************************************************)
(** ** Other properties of binary integer numbers *)

Lemma ZL0 : 2%nat = (1 + 1)%nat.
Proof.
  reflexivity.
Qed.

(**********************************************************************)
(** * Properties of the addition on integers *)

(** ** Zero is left neutral for addition *)

Theorem Zplus_0_l : forall n:Z, Z0 + n = n.
Proof.
  intro x; destruct x; reflexivity.
Qed.

(** ** Zero is right neutral for addition *)

Theorem Zplus_0_r : forall n:Z, n + Z0 = n.
Proof.
  intro x; destruct x; reflexivity.
Qed.

(** ** Addition is commutative *)

Theorem Zplus_comm : forall n m:Z, n + m = m + n.
Proof.
  induction n as [|p|p]; intros [|q|q]; simpl; try reflexivity.
  rewrite Pplus_comm; reflexivity.
  rewrite ZC4. now case Pcompare_spec.
  rewrite ZC4; now case Pcompare_spec.
  rewrite Pplus_comm; reflexivity.
Qed.

(** ** Opposite distributes over addition *)

Theorem Zopp_plus_distr : forall n m:Z, - (n + m) = - n + - m.
Proof.
  intro x; destruct x as [| p| p]; intro y; destruct y as [| q| q];
    simpl; reflexivity || destruct ((p ?= q)%positive Eq);
      reflexivity.
Qed.

Theorem Zopp_succ : forall n:Z, Zopp (Zsucc n) = Zpred (Zopp n).
Proof.
intro; unfold Zsucc; now rewrite Zopp_plus_distr.
Qed.

(** ** Opposite is inverse for addition *)

Theorem Zplus_opp_r : forall n:Z, n + - n = Z0.
Proof.
  intro x; destruct x as [| p| p]; simpl;
    [ reflexivity
      | rewrite (Pcompare_refl p); reflexivity
      | rewrite (Pcompare_refl p); reflexivity ].
Qed.

Theorem Zplus_opp_l : forall n:Z, - n + n = Z0.
Proof.
  intro; rewrite Zplus_comm; apply Zplus_opp_r.
Qed.

Hint Local Resolve Zplus_0_l Zplus_0_r.

(** ** Addition is associative *)

Lemma weak_assoc :
  forall (p q:positive) (n:Z), Zpos p + (Zpos q + n) = Zpos p + Zpos q + n.
Proof.
 intros x y [|z|z]; simpl; trivial.
 now rewrite Pplus_assoc.
 case (Pcompare_spec y z); intros E0.
 (* y = z *)
 subst.
 assert (H := Plt_plus_r z x). rewrite Pplus_comm in H. apply ZC2 in H.
 now rewrite H, Pplus_minus_eq.
 (* y < z *)
 assert (Hz : (z = (z-y)+y)%positive).
  rewrite Pplus_comm, Pplus_minus_lt; trivial.
 pattern z at 4. rewrite Hz, Pplus_compare_mono_r.
 case Pcompare_spec; intros E1; trivial; f_equal.
 symmetry. rewrite Pplus_comm. apply Pminus_plus_distr.
 rewrite Hz, Pplus_comm. now apply Pplus_lt_mono_r.
 apply Pminus_minus_distr; trivial.
 (* z < y *)
 assert (LT : (z < x + y)%positive).
  rewrite Pplus_comm. apply Plt_trans with y; trivial using Plt_plus_r.
 apply ZC2 in LT. rewrite LT. f_equal.
 now apply Pplus_minus_assoc.
Qed.

Theorem Zplus_assoc : forall n m p:Z, n + (m + p) = n + m + p.
Proof.
 intros [|x|x] [|y|y] [|z|z]; trivial.
 apply weak_assoc.
 apply weak_assoc.
 now rewrite !Zplus_0_r.
 rewrite 2 (Zplus_comm _ (Zpos z)), 2 weak_assoc.
  f_equal; apply Zplus_comm.
 apply Zopp_inj. rewrite !Zopp_plus_distr, !Zopp_neg.
  rewrite 2 (Zplus_comm (-Zpos x)), 2 (Zplus_comm _ (Zpos z)).
  now rewrite weak_assoc.
 now rewrite !Zplus_0_r.
 rewrite 2 (Zplus_comm (Zneg x)), 2 (Zplus_comm _ (Zpos z)).
  now rewrite weak_assoc.
 apply Zopp_inj. rewrite !Zopp_plus_distr, !Zopp_neg.
 rewrite 2 (Zplus_comm _ (Zpos z)), 2 weak_assoc.
  f_equal; apply Zplus_comm.
 apply Zopp_inj. rewrite !Zopp_plus_distr, !Zopp_neg.
  apply weak_assoc.
 apply Zopp_inj. rewrite !Zopp_plus_distr, !Zopp_neg.
  apply weak_assoc.
Qed.

Lemma Zplus_assoc_reverse : forall n m p:Z, n + m + p = n + (m + p).
Proof.
  intros; symmetry ; apply Zplus_assoc.
Qed.

(** ** Associativity mixed with commutativity *)

Theorem Zplus_permute : forall n m p:Z, n + (m + p) = m + (n + p).
Proof.
  intros n m p; rewrite Zplus_comm; rewrite <- Zplus_assoc;
    rewrite (Zplus_comm p n); trivial with arith.
Qed.

(** ** Addition simplifies *)

Theorem Zplus_reg_l : forall n m p:Z, n + m = n + p -> m = p.
  intros n m p H; cut (- n + (n + m) = - n + (n + p));
    [ do 2 rewrite Zplus_assoc; rewrite (Zplus_comm (- n) n);
      rewrite Zplus_opp_r; simpl; trivial with arith
      | rewrite H; trivial with arith ].
Qed.

(** ** Addition and successor permutes *)

Lemma Zplus_succ_l : forall n m:Z, Zsucc n + m = Zsucc (n + m).
Proof.
  intros x y; unfold Zsucc; rewrite (Zplus_comm (x + y));
    rewrite Zplus_assoc; rewrite (Zplus_comm (Zpos 1));
      trivial with arith.
Qed.

Lemma Zplus_succ_r_reverse : forall n m:Z, Zsucc (n + m) = n + Zsucc m.
Proof.
  intros n m; unfold Zsucc; rewrite Zplus_assoc; trivial with arith.
Qed.

Notation Zplus_succ_r := Zplus_succ_r_reverse (only parsing).

Lemma Zplus_succ_comm : forall n m:Z, Zsucc n + m = n + Zsucc m.
Proof.
  unfold Zsucc; intros n m; rewrite <- Zplus_assoc;
    rewrite (Zplus_comm (Zpos 1)); trivial with arith.
Qed.

(** ** Misc properties, usually redundant or non natural *)

Lemma Zplus_0_r_reverse : forall n:Z, n = n + Z0.
Proof.
  symmetry ; apply Zplus_0_r.
Qed.

Lemma Zplus_0_simpl_l : forall n m:Z, n + Z0 = m -> n = m.
Proof.
  intros n m; rewrite Zplus_0_r; intro; assumption.
Qed.

Lemma Zplus_0_simpl_l_reverse : forall n m:Z, n = m + Z0 -> n = m.
Proof.
  intros n m; rewrite Zplus_0_r; intro; assumption.
Qed.

Lemma Zplus_eq_compat : forall n m p q:Z, n = m -> p = q -> n + p = m + q.
Proof.
  intros; rewrite H; rewrite H0; reflexivity.
Qed.

Lemma Zplus_opp_expand : forall n m p:Z, n + - m = n + - p + (p + - m).
Proof.
  intros x y z.
  rewrite <- (Zplus_assoc x).
  rewrite (Zplus_assoc (- z)).
  rewrite Zplus_opp_l.
  reflexivity.
Qed.

(************************************************************************)
(** * Properties of successor and predecessor on binary integer numbers *)

Theorem Zsucc_discr : forall n:Z, n <> Zsucc n.
Proof.
  intros n; cut (Z0 <> Zpos 1);
    [ unfold not; intros H1 H2; apply H1; apply (Zplus_reg_l n);
      rewrite Zplus_0_r; exact H2
      | discriminate ].
Qed.

Theorem Zpos_succ_morphism :
  forall p:positive, Zpos (Psucc p) = Zsucc (Zpos p).
Proof.
  intro; rewrite Pplus_one_succ_r; unfold Zsucc; simpl;
    trivial with arith.
Qed.

(** successor and predecessor are inverse functions *)

Theorem Zsucc_pred : forall n:Z, n = Zsucc (Zpred n).
Proof.
  intros n; unfold Zsucc, Zpred; rewrite <- Zplus_assoc; simpl;
    rewrite Zplus_0_r; trivial with arith.
Qed.

Hint Immediate Zsucc_pred: zarith.

Theorem Zpred_succ : forall n:Z, n = Zpred (Zsucc n).
Proof.
  intros m; unfold Zpred, Zsucc; rewrite <- Zplus_assoc; simpl;
    rewrite Zplus_comm; auto with arith.
Qed.

Theorem Zsucc_inj : forall n m:Z, Zsucc n = Zsucc m -> n = m.
Proof.
  intros n m H.
  change (Zneg 1 + Zpos 1 + n = Zneg 1 + Zpos 1 + m);
    do 2 rewrite <- Zplus_assoc; do 2 rewrite (Zplus_comm (Zpos 1));
      unfold Zsucc in H; rewrite H; trivial with arith.
Qed.

(*************************************************************************)
(** **  Properties of the direct definition of successor and predecessor *)

Theorem Zsucc_succ' : forall n:Z, Zsucc n = Zsucc' n.
Proof.
destruct n as [| p | p]; simpl.
reflexivity.
now rewrite Pplus_one_succ_r.
now destruct p as [q | q |].
Qed.

Theorem Zpred_pred' : forall n:Z, Zpred n = Zpred' n.
Proof.
destruct n as [| p | p]; simpl.
reflexivity.
now destruct p as [q | q |].
now rewrite Pplus_one_succ_r.
Qed.

Theorem Zsucc'_inj : forall n m:Z, Zsucc' n = Zsucc' m -> n = m.
Proof.
intros n m; do 2 rewrite <- Zsucc_succ'; now apply Zsucc_inj.
Qed.

Theorem Zsucc'_pred' : forall n:Z, Zsucc' (Zpred' n) = n.
Proof.
intro; rewrite <- Zsucc_succ'; rewrite <- Zpred_pred';
symmetry; apply Zsucc_pred.
Qed.

Theorem Zpred'_succ' : forall n:Z, Zpred' (Zsucc' n) = n.
Proof.
intro; apply Zsucc'_inj; now rewrite Zsucc'_pred'.
Qed.

Theorem Zpred'_inj : forall n m:Z, Zpred' n = Zpred' m -> n = m.
Proof.
intros n m H.
rewrite <- (Zsucc'_pred' n); rewrite <- (Zsucc'_pred' m); now rewrite H.
Qed.

Theorem Zsucc'_discr : forall n:Z, n <> Zsucc' n.
Proof.
  intro x; destruct x; simpl.
  discriminate.
  injection; apply Psucc_discr.
  destruct p; simpl.
    discriminate.
    intro H; symmetry  in H; injection H; apply double_moins_un_xO_discr.
    discriminate.
Qed.

(** Misc properties, usually redundant or non natural *)

Lemma Zsucc_eq_compat : forall n m:Z, n = m -> Zsucc n = Zsucc m.
Proof.
  intros n m H; rewrite H; reflexivity.
Qed.

Lemma Zsucc_inj_contrapositive : forall n m:Z, n <> m -> Zsucc n <> Zsucc m.
Proof.
  unfold not; intros n m H1 H2; apply H1; apply Zsucc_inj; assumption.
Qed.

(**********************************************************************)
(** * Properties of subtraction on binary integer numbers *)

(** ** [minus] and [Z0] *)

Lemma Zminus_0_r : forall n:Z, n - Z0 = n.
Proof.
  intro; unfold Zminus; simpl; rewrite Zplus_0_r;
    trivial with arith.
Qed.

Lemma Zminus_0_l_reverse : forall n:Z, n = n - Z0.
Proof.
  intro; symmetry ; apply Zminus_0_r.
Qed.

Lemma Zminus_diag : forall n:Z, n - n = Z0.
Proof.
  intro; unfold Zminus; rewrite Zplus_opp_r; trivial with arith.
Qed.

Lemma Zminus_diag_reverse : forall n:Z, Z0 = n - n.
Proof.
  intro; symmetry ; apply Zminus_diag.
Qed.

(** ** Relating [minus] with [plus] and [Zsucc] *)

Lemma Zminus_plus_distr : forall n m p:Z, n - (m + p) = n - m - p.
Proof.
intros; unfold Zminus; rewrite Zopp_plus_distr; apply Zplus_assoc.
Qed.

Lemma Zminus_succ_l : forall n m:Z, Zsucc (n - m) = Zsucc n - m.
Proof.
  intros n m; unfold Zminus, Zsucc; rewrite (Zplus_comm n (- m));
    rewrite <- Zplus_assoc; apply Zplus_comm.
Qed.

Lemma Zminus_succ_r : forall n m:Z, n - (Zsucc m) = Zpred (n - m).
Proof.
intros; unfold Zsucc; now rewrite Zminus_plus_distr.
Qed.

Lemma Zplus_minus_eq : forall n m p:Z, n = m + p -> p = n - m.
Proof.
  intros n m p H; unfold Zminus; apply (Zplus_reg_l m);
    rewrite (Zplus_comm m (n + - m)); rewrite <- Zplus_assoc;
      rewrite Zplus_opp_l; rewrite Zplus_0_r; rewrite H;
	trivial with arith.
Qed.

Lemma Zminus_plus : forall n m:Z, n + m - n = m.
Proof.
  intros n m; unfold Zminus; rewrite (Zplus_comm n m);
    rewrite <- Zplus_assoc; rewrite Zplus_opp_r; apply Zplus_0_r.
Qed.

Lemma Zplus_minus : forall n m:Z, n + (m - n) = m.
Proof.
  unfold Zminus; intros n m; rewrite Zplus_permute; rewrite Zplus_opp_r;
    apply Zplus_0_r.
Qed.

Lemma Zminus_plus_simpl_l : forall n m p:Z, p + n - (p + m) = n - m.
Proof.
  intros n m p; unfold Zminus; rewrite Zopp_plus_distr;
    rewrite Zplus_assoc; rewrite (Zplus_comm p); rewrite <- (Zplus_assoc n p);
      rewrite Zplus_opp_r; rewrite Zplus_0_r; trivial with arith.
Qed.

Lemma Zminus_plus_simpl_l_reverse : forall n m p:Z, n - m = p + n - (p + m).
Proof.
  intros; symmetry ; apply Zminus_plus_simpl_l.
Qed.

Lemma Zminus_plus_simpl_r : forall n m p:Z, n + p - (m + p) = n - m.
Proof.
  intros x y n.
  unfold Zminus.
  rewrite Zopp_plus_distr.
  rewrite (Zplus_comm (- y) (- n)).
  rewrite Zplus_assoc.
  rewrite <- (Zplus_assoc x n (- n)).
  rewrite (Zplus_opp_r n).
  rewrite <- Zplus_0_r_reverse.
  reflexivity.
Qed.

Lemma Zpos_minus_morphism : forall a b:positive, Pcompare a b Eq = Lt ->
  Zpos (b-a) = Zpos b - Zpos a.
Proof.
  intros.
  simpl.
  change Eq with (CompOpp Eq).
  rewrite <- Pcompare_antisym.
  rewrite H; simpl; auto.
Qed.

(** ** Misc redundant properties *)

Lemma Zeq_minus : forall n m:Z, n = m -> n - m = Z0.
Proof.
  intros x y H; rewrite H; symmetry ; apply Zminus_diag_reverse.
Qed.

Lemma Zminus_eq : forall n m:Z, n - m = Z0 -> n = m.
Proof.
  intros x y H; rewrite <- (Zplus_minus y x); rewrite H; apply Zplus_0_r.
Qed.

(**********************************************************************)
(** * Properties of multiplication on binary integer numbers *)

Theorem Zpos_mult_morphism :
  forall p q:positive, Zpos (p*q) = Zpos p * Zpos q.
Proof.
  auto.
Qed.

(** ** One is neutral for multiplication *)

Theorem Zmult_1_l : forall n:Z, Zpos 1 * n = n.
Proof.
  intro x; destruct x; reflexivity.
Qed.

Theorem Zmult_1_r : forall n:Z, n * Zpos 1 = n.
Proof.
  intro x; destruct x; simpl; try rewrite Pmult_1_r; reflexivity.
Qed.

(** ** Zero property of multiplication *)

Theorem Zmult_0_l : forall n:Z, Z0 * n = Z0.
Proof.
  intro x; destruct x; reflexivity.
Qed.

Theorem Zmult_0_r : forall n:Z, n * Z0 = Z0.
Proof.
  intro x; destruct x; reflexivity.
Qed.

Hint Local Resolve Zmult_0_l Zmult_0_r.

Lemma Zmult_0_r_reverse : forall n:Z, Z0 = n * Z0.
Proof.
  intro x; destruct x; reflexivity.
Qed.

(** ** Commutativity of multiplication *)

Theorem Zmult_comm : forall n m:Z, n * m = m * n.
Proof.
  intros x y; destruct x as [| p| p]; destruct y as [| q| q]; simpl;
    try rewrite (Pmult_comm p q); reflexivity.
Qed.

(** ** Associativity of multiplication *)

Theorem Zmult_assoc : forall n m p:Z, n * (m * p) = n * m * p.
Proof.
  intros x y z; destruct x; destruct y; destruct z; simpl;
    try rewrite Pmult_assoc; reflexivity.
Qed.

Lemma Zmult_assoc_reverse : forall n m p:Z, n * m * p = n * (m * p).
Proof.
  intros n m p; rewrite Zmult_assoc; trivial with arith.
Qed.

(** ** Associativity mixed with commutativity *)

Theorem Zmult_permute : forall n m p:Z, n * (m * p) = m * (n * p).
Proof.
  intros x y z; rewrite (Zmult_assoc y x z); rewrite (Zmult_comm y x).
  apply Zmult_assoc.
Qed.

(** ** Z is integral *)

Theorem Zmult_integral_l : forall n m:Z, n <> Z0 -> m * n = Z0 -> m = Z0.
Proof.
  intros x y; destruct x as [| p| p].
  intro H; absurd (Z0 = Z0); trivial.
  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
  intros _ H; destruct y as [| q| q]; reflexivity || discriminate.
Qed.

Theorem Zmult_integral : forall n m:Z, n * m = Z0 -> n = Z0 \/ m = Z0.
Proof.
  intros x y; destruct x; destruct y; auto; simpl; intro H;
    discriminate H.
Qed.

Lemma Zmult_1_inversion_l :
  forall n m:Z, n * m = Zpos 1 -> n = Zpos 1 \/ n = Zneg 1.
Proof.
  intros x y; destruct x as [| p| p]; intro; [ discriminate | left | right ];
    (destruct y as [| q| q]; try discriminate; simpl in H; injection H; clear H;
      intro H; rewrite Pmult_1_inversion_l with (1 := H);
	reflexivity).
Qed.

(** ** Multiplication and Doubling *)

Lemma Zdouble_mult : forall z, Zdouble z = (Zpos 2) * z.
Proof.
  reflexivity.
Qed.

Lemma Zdouble_plus_one_mult : forall z,
  Zdouble_plus_one z = (Zpos 2) * z + (Zpos 1).
Proof.
  destruct z; simpl; auto with zarith.
Qed.

(** ** Multiplication and Opposite *)

Theorem Zopp_mult_distr_l : forall n m:Z, - (n * m) = - n * m.
Proof.
  intros x y; destruct x; destruct y; reflexivity.
Qed.

Theorem Zopp_mult_distr_r : forall n m:Z, - (n * m) = n * - m.
Proof.
  intros x y; rewrite (Zmult_comm x y); rewrite Zopp_mult_distr_l;
    apply Zmult_comm.
Qed.

Lemma Zopp_mult_distr_l_reverse : forall n m:Z, - n * m = - (n * m).
Proof.
  intros x y; symmetry ; apply Zopp_mult_distr_l.
Qed.

Theorem Zmult_opp_comm : forall n m:Z, - n * m = n * - m.
Proof.
  intros x y; rewrite Zopp_mult_distr_l_reverse; rewrite Zopp_mult_distr_r;
    trivial with arith.
Qed.

Theorem Zmult_opp_opp : forall n m:Z, - n * - m = n * m.
Proof.
  intros x y; destruct x; destruct y; reflexivity.
Qed.

Theorem Zopp_eq_mult_neg_1 : forall n:Z, - n = n * Zneg 1.
Proof.
  intro x; induction x; intros; rewrite Zmult_comm; auto with arith.
Qed.

(** ** Distributivity of multiplication over addition *)

Lemma weak_Zmult_plus_distr_r :
  forall (p:positive) (n m:Z), Zpos p * (n + m) = Zpos p * n + Zpos p * m.
Proof.
 intros x [ |y|y] [ |z|z]; simpl; trivial; f_equal;
  apply Pmult_plus_distr_l || rewrite Pmult_compare_mono_l;
  case_eq ((y ?= z) Eq)%positive; intros H; trivial;
   rewrite Pmult_minus_distr_l; trivial; now apply ZC1.
Qed.

Theorem Zmult_plus_distr_r : forall n m p:Z, n * (m + p) = n * m + n * p.
Proof.
 intros [|x|x] y z. trivial.
 apply weak_Zmult_plus_distr_r.
 apply Zopp_inj; rewrite Zopp_plus_distr, !Zopp_mult_distr_l, !Zopp_neg.
 apply weak_Zmult_plus_distr_r.
Qed.

Theorem Zmult_plus_distr_l : forall n m p:Z, (n + m) * p = n * p + m * p.
Proof.
  intros n m p; rewrite Zmult_comm; rewrite Zmult_plus_distr_r;
    do 2 rewrite (Zmult_comm p); trivial with arith.
Qed.

(** ** Distributivity of multiplication over subtraction *)

Lemma Zmult_minus_distr_r : forall n m p:Z, (n - m) * p = n * p - m * p.
Proof.
  intros x y z; unfold Zminus.
  rewrite <- Zopp_mult_distr_l_reverse.
  apply Zmult_plus_distr_l.
Qed.

Lemma Zmult_minus_distr_l : forall n m p:Z, p * (n - m) = p * n - p * m.
Proof.
  intros x y z; rewrite (Zmult_comm z (x - y)).
  rewrite (Zmult_comm z x).
  rewrite (Zmult_comm z y).
  apply Zmult_minus_distr_r.
Qed.

(** ** Simplification of multiplication for non-zero integers *)

Lemma Zmult_reg_l : forall n m p:Z, p <> Z0 -> p * n = p * m -> n = m.
Proof.
  intros x y z H H0.
  generalize (Zeq_minus _ _ H0).
  intro.
  apply Zminus_eq.
  rewrite <- Zmult_minus_distr_l in H1.
  clear H0; destruct (Zmult_integral _ _ H1).
  contradiction.
  trivial.
Qed.

Lemma Zmult_reg_r : forall n m p:Z, p <> Z0 -> n * p = m * p -> n = m.
Proof.
  intros x y z Hz.
  rewrite (Zmult_comm x z).
  rewrite (Zmult_comm y z).
  intro; apply Zmult_reg_l with z; assumption.
Qed.

(** ** Addition and multiplication by 2 *)

Lemma Zplus_diag_eq_mult_2 : forall n:Z, n + n = n * Zpos 2.
Proof.
  intros x; pattern x at 1 2; rewrite <- (Zmult_1_r x);
    rewrite <- Zmult_plus_distr_r; reflexivity.
Qed.

(** ** Multiplication and successor *)

Lemma Zmult_succ_r : forall n m:Z, n * Zsucc m = n * m + n.
Proof.
  intros n m; unfold Zsucc; rewrite Zmult_plus_distr_r;
    rewrite (Zmult_comm n (Zpos 1)); rewrite Zmult_1_l;
      trivial with arith.
Qed.

Lemma Zmult_succ_r_reverse : forall n m:Z, n * m + n = n * Zsucc m.
Proof.
  intros; symmetry ; apply Zmult_succ_r.
Qed.

Lemma Zmult_succ_l : forall n m:Z, Zsucc n * m = n * m + m.
Proof.
  intros n m; unfold Zsucc; rewrite Zmult_plus_distr_l;
    rewrite Zmult_1_l; trivial with arith.
Qed.

Lemma Zmult_succ_l_reverse : forall n m:Z, n * m + m = Zsucc n * m.
Proof.
  intros; symmetry; apply Zmult_succ_l.
Qed.

(** ** Misc redundant properties *)

Lemma Z_eq_mult : forall n m:Z, m = Z0 -> m * n = Z0.
Proof.
  intros x y H; rewrite H; auto with arith.
Qed.

(**********************************************************************)
(** * Relating binary positive numbers and binary integers *)

Lemma Zpos_eq : forall p q:positive, p = q -> Zpos p = Zpos q.
Proof.
  intros; f_equal; auto.
Qed.

Lemma Zpos_eq_rev : forall p q:positive, Zpos p = Zpos q -> p = q.
Proof.
  inversion 1; auto.
Qed.

Lemma Zpos_eq_iff : forall p q:positive, p = q <-> Zpos p = Zpos q.
Proof.
  split; [apply Zpos_eq|apply Zpos_eq_rev].
Qed.

Lemma Zpos_xI : forall p:positive, Zpos p~1 = Zpos 2 * Zpos p + Zpos 1.
Proof.
  intro; apply refl_equal.
Qed.

Lemma Zpos_xO : forall p:positive, Zpos p~0 = Zpos 2 * Zpos p.
Proof.
  intro; apply refl_equal.
Qed.

Lemma Zneg_xI : forall p:positive, Zneg p~1 = Zpos 2 * Zneg p - Zpos 1.
Proof.
  intro; apply refl_equal.
Qed.

Lemma Zneg_xO : forall p:positive, Zneg p~0 = Zpos 2 * Zneg p.
Proof.
  reflexivity.
Qed.

Lemma Zpos_plus_distr : forall p q:positive, Zpos (p + q) = Zpos p + Zpos q.
Proof.
  intros p p'; destruct p;
    [ destruct p' as [p0| p0| ]
      | destruct p' as [p0| p0| ]
      | destruct p' as [p| p| ] ]; reflexivity.
Qed.

Lemma Zneg_plus_distr : forall p q:positive, Zneg (p + q) = Zneg p + Zneg q.
Proof.
  intros p p'; destruct p;
    [ destruct p' as [p0| p0| ]
      | destruct p' as [p0| p0| ]
      | destruct p' as [p| p| ] ]; reflexivity.
Qed.

(**********************************************************************)
(** * Order relations *)

Definition Zlt (x y:Z) := (x ?= y) = Lt.
Definition Zgt (x y:Z) := (x ?= y) = Gt.
Definition Zle (x y:Z) := (x ?= y) <> Gt.
Definition Zge (x y:Z) := (x ?= y) <> Lt.
Definition Zne (x y:Z) := x <> y.

Infix "<=" := Zle : Z_scope.
Infix "<" := Zlt : Z_scope.
Infix ">=" := Zge : Z_scope.
Infix ">" := Zgt : Z_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z) : Z_scope.
Notation "x <= y < z" := (x <= y /\ y < z) : Z_scope.
Notation "x < y < z" := (x < y /\ y < z) : Z_scope.
Notation "x < y <= z" := (x < y /\ y <= z) : Z_scope.

Lemma Zpos_lt : forall p q, Zlt (Zpos p) (Zpos q) <-> Plt p q.
Proof.
 intros. apply iff_refl.
Qed.

Lemma Zpos_le : forall p q, Zle (Zpos p) (Zpos q) <-> Ple p q.
Proof.
 intros. apply iff_refl.
Qed.

(**********************************************************************)
(** * Minimum and maximum *)

Definition Zmax (n m:Z) :=
  match n ?= m with
    | Eq | Gt => n
    | Lt => m
  end.

Definition Zmin (n m:Z) :=
  match n ?= m with
    | Eq | Lt => n
    | Gt => m
  end.

(**********************************************************************)
(** * Absolute value on integers *)

Definition Zabs_nat (x:Z) : nat :=
  match x with
    | Z0 => 0%nat
    | Zpos p => nat_of_P p
    | Zneg p => nat_of_P p
  end.

Definition Zabs (z:Z) : Z :=
  match z with
    | Z0 => Z0
    | Zpos p => Zpos p
    | Zneg p => Zpos p
  end.

(**********************************************************************)
(** * From [nat] to [Z] *)

Definition Z_of_nat (x:nat) :=
  match x with
    | O => Z0
    | S y => Zpos (P_of_succ_nat y)
  end.

Definition Zabs_N (z:Z) :=
  match z with
    | Z0 => 0%N
    | Zpos p => Npos p
    | Zneg p => Npos p
  end.

Definition Z_of_N (x:N) :=
  match x with
    | N0 => Z0
    | Npos p => Zpos p
  end.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   prime.
   The primality predicate.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision$
*)

Require Import ZArith.
Require Import Wf_nat.

Require Import lemmas.
Require Import natZ.
Require Import dec.
Require Import divides.
Require Import modulo.
Require Import list.

(** * Primality on nat *)

Definition Prime (n : nat) : Prop :=
  n > 1 /\ (forall q : nat, Divides q n -> q = 1 \/ q = n).

(** Prime with bounded all quantifier. *)

Definition bPrime (n : nat) :=
  n > 1 /\ (forall q : nat, q < S n -> Divides q n -> q = 1 \/ q = n).

Lemma primebprime : forall n : nat, Prime n <-> bPrime n.
Proof.
   unfold Prime, bPrime in |- *.
   split.
   intro. elim H.
   split.
   assumption.
   intros.
   apply H1.
   assumption.
   intro. elim H.
   split.
   assumption.
   intros.
   apply H1.
   unfold lt in |- *.
   apply le_n_S.
   apply div_le.
   apply lt_trans with 1. apply lt_O_Sn. assumption.
   assumption.
   assumption.
Qed.

(** Prime is decidable. *)

Lemma bprimedec : forall n : nat, bPrime n \/ ~ bPrime n.
Proof.
   unfold bPrime in |- *. intros.
   apply anddec.
   apply gtdec.
   apply (alldec (fun q : nat => Divides q n -> q = 1 \/ q = n) (S n)).
   intros.
   apply impdec.
   apply divdec.
   apply ordec.
   apply eqdec.
   apply eqdec.
Qed.

Lemma primedec : forall n : nat, Prime n \/ ~ Prime n.
Proof.
   intro. elim (primebprime n).
   intros. elim (bprimedec n).
   left. apply (H0 H1).
   right. intro. apply H1. apply (H H2).
Qed.

(** Non-primes n>1 have non-trivial divisors. *)

Lemma nonprime_witness :
 forall n : nat,
 n > 1 -> ~ Prime n -> exists d : nat, 1 < d /\ d < n /\ Divides d n.
Proof.
   intro n. case n.
   intro. elim (lt_n_O 1). assumption.
   intro n1. case n1. intro. elim (lt_irrefl 1). assumption.
   intro n2. intros.
   elim
    (decDeMorgan (S (S n2)) (fun d : nat => 1 < d /\ Divides d (S (S n2)))).
   intros. elim H2. intros.
   split with x.
   elim H3. intros.
   elim H5. intros.
   split.
   assumption.
   split.
   assumption.
   assumption.
   intro. apply H0. unfold Prime in |- *. split. assumption.
   intro q. case q.
   intro. unfold Divides in H4. elim H4. simpl in |- *. intros. discriminate H5.
   intro q1. case q1. left. reflexivity.
   intro q2. intros. right.
   elim (le_lt_or_eq (S (S q2)) (S (S n2))).
   intros. elim (H3 (S (S q2))). assumption.
   split. apply lt_n_S. apply lt_O_Sn. assumption.
   intros. assumption.
   apply div_le1. assumption.
   intros. apply anddec. apply ltdec. apply divdec.
Qed.

Lemma nonprime_sqrwitness :
 forall n : nat,
 n > 1 -> ~ Prime n -> exists d : nat, 1 < d /\ d * d <= n /\ Divides d n.
Proof.
   intros. elim (nonprime_witness n).
   intro d. intros.
   elim (sqrdivbound n d). intro d'. intros.
   elim H2. intros.
   elim H4. intros.
   elim H6.
   intro. split with d'.
   split. rewrite H7. elim H1. tauto.
   split. assumption.
   rewrite H7. elim H1. tauto.
   intro. split with d'. split. apply (lt_n_nm_m_gt_1 d d').
   rewrite H7. elim H1. tauto.
   split. assumption.
   assumption.
   elim H1. tauto.
   assumption.
   assumption.
Qed.

(** Non-primes n>1 have prime-divisors. *)

Theorem nonprime_primewitness :
 forall n : nat,
 n > 1 ->
 ~ Prime n -> exists d : nat, 1 < d /\ d * d <= n /\ Divides d n /\ Prime d.
Proof.
   intro. apply (lt_wf_ind n).
   intros N IH. intros.
   elim (nonprime_sqrwitness N). intro x. intros.
   elim H1. intros.
   elim H3. intros.
   elim (primedec x).
   intros.
   split with x.
   split. assumption.
   split. assumption.
   split. assumption.
   assumption.
   intros. elim (IH x). intros.
   elim H7. intros.
   elim H9. intros.
   elim H11.
   intros.
   split with x0.
   split. assumption.
   split. apply le_trans with (x * x).
   apply le_trans with x. assumption. apply le_n_nn. assumption.
   split. apply div_trans with x. assumption. assumption.
   assumption.
   unfold lt in |- *. apply le_trans with (x * x).
   change (x < x * x) in |- *. apply sqr_ascend. assumption.
   assumption. assumption. assumption. assumption. assumption.
Qed.

(** Prime(n) if all prime divisors > sqrt(n). *)

Theorem primepropdiv :
 forall n : nat,
 n > 1 -> (forall q : nat, Prime q -> Divides q n -> q * q > n) -> Prime n.
Proof.
   intros. elim (primedec n).
   intro. assumption.
   intros. elim (nonprime_primewitness n).
   intros.
   elim H2. intros.
   elim H4. intros.
   elim H6. intros.
   elim (le_not_lt (x * x) n).
   assumption.
   unfold gt in H0. apply H0. assumption. assumption.
   assumption.
   assumption.
Qed.

Lemma primediv1p : forall p n : nat, Prime p -> Divides n p -> n = 1 \/ n = p.
Proof.
   intros.
   unfold Prime in H. elim H. intros.
   apply (H2 n). assumption.
Qed.

(** Two is a prime. *)

Lemma prime2 : Prime 2.
Proof.
   apply primepropdiv.
   auto.
   intro q. case q.
   intros. elim H. intro.
   elim (lt_n_O 1). assumption.
   intro q1. case q1.
   intros. elim H. intro.
   elim (lt_irrefl 1). assumption.
   intro q2. case q2.
   simpl in |- *. intros. auto.
   intro q3. simpl in |- *. intros.
   repeat apply gt_n_S. apply gt_Sn_O.
Qed.

(** * Primality on Z *)

(** ZPrime, just like Prime but uses only Z. *)

Definition ZPrime (n : Z) : Prop :=
  (n > 1)%Z /\ (forall q : Z, (q >= 0)%Z -> ZDivides q n -> q = 1%Z \/ q = n).

Lemma primezprime : forall n : nat, Prime n -> ZPrime (Z_of_nat n).
Proof.
   unfold Prime, ZPrime in |- *. intros.
   elim H. intros. split.
   change (Z_of_nat n > Z_of_nat 1)%Z in |- *.
   apply Znat.inj_gt. assumption.
   intros. elim (H1 (Z.abs_nat q)).
   left. rewrite <- (inj_abs_pos q). rewrite H4.
   simpl in |- *. reflexivity. assumption.
   right. rewrite <- (inj_abs_pos q). rewrite H4.
   reflexivity. assumption.
   rewrite <- (abs_inj n).
   apply zdivdiv. assumption.
Qed.

Lemma zprimeprime : forall n : Z, ZPrime n -> Prime (Z.abs_nat n).
Proof.
   unfold ZPrime, Prime in |- *. intros.
   elim H. intros. split.
   change (Z.abs_nat n > Z.abs_nat 1) in |- *.
   apply gtzgt.
   apply Z.le_trans with 1%Z.
   unfold Z.le in |- *. simpl in |- *. discriminate.
   apply Zlt_le_weak. apply Z.gt_lt. assumption.
   unfold Z.le in |- *. simpl in |- *. discriminate.
   assumption.
   intros. elim (H1 (Z_of_nat q)).
   left. rewrite <- (abs_inj q). rewrite H3.
   simpl in |- *. reflexivity.
   right. rewrite <- (abs_inj q). rewrite H3.
   reflexivity. apply nat_ge_0.
   apply divzdiv. rewrite abs_inj. assumption.
Qed.

Lemma zprime2 : ZPrime 2.
Proof.
   change (ZPrime (Z_of_nat 2)) in |- *.
   apply primezprime.
   exact prime2.
Qed.

Lemma zprime2a : ZPrime 2.
Proof.
   exact zprime2.
Qed.

(** All numbers in natlist are prime. *)

Definition allPrime : natlist -> Prop := alllist nat Prime.

Definition allZPrime : Zlist -> Prop := alllist Z ZPrime.

Lemma allzprimeallpos : forall l : Zlist, allZPrime l -> allPos l.
Proof.
   unfold allZPrime, allPos in |- *.
   simple induction l.
   simpl in |- *. intro. assumption.
   simpl in |- *. intros h t IH H.
   elim H. intros. elim H0. intros.
   split. apply Z.le_ge. apply Z.le_trans with 1%Z.
   unfold Z.le in |- *. simpl in |- *. discriminate.
   apply Zlt_le_weak. apply Z.gt_lt. assumption.
   apply IH. assumption.
Qed.

Lemma allprimeallzprime :
 forall l : natlist, allPrime l -> allZPrime (map _ _ Z_of_nat l).
Proof.
   unfold allPrime, allZPrime in |- *.
   simple induction l.
   simpl in |- *. intro. assumption.
   simpl in |- *. intros h t IH H. elim H. intros. split.
   apply primezprime. assumption.
   apply IH. assumption.
Qed.

Lemma allzprimeallprime :
 forall l : Zlist, allZPrime l -> allPrime (map _ _ Z.abs_nat l).
Proof.
   unfold allPrime, allZPrime in |- *.
   simple induction l.
   simpl in |- *. intro. assumption.
   simpl in |- *. intros h t IH H. elim H. intros. split.
   apply zprimeprime. assumption.
   apply IH. assumption.
Qed.


(** * Equational reasoning for Riesz Spaces *)
Require Import CMorphisms.
Require Import RL.hr.Rterm.

Require Import Reals.
Require Import Lra.

Local Open Scope R_scope.

(** ** Basic definitions needed for equational reasoning *)
(** Context *)
Inductive Rcontext : Type :=
| R_hole : Rcontext
| R_TC : Rterm -> Rcontext
| R_varC : nat -> Rcontext
| R_zeroC : Rcontext
| R_minC : Rcontext -> Rcontext -> Rcontext
| R_maxC : Rcontext -> Rcontext -> Rcontext
| R_plusC : Rcontext -> Rcontext -> Rcontext
| R_mulC : R -> Rcontext -> Rcontext.

Fixpoint evalRcontext (c : Rcontext) (t : Rterm) : Rterm :=
  match c with
  | R_hole => t
  | R_TC t' => t'
  | R_varC n => R_var n
  | R_zeroC => R_zero
  | R_minC c1 c2 => R_min (evalRcontext c1 t) (evalRcontext c2 t)
  | R_maxC c1 c2 => R_max (evalRcontext c1 t) (evalRcontext c2 t)
  | R_plusC c1 c2 => R_plus (evalRcontext c1 t) (evalRcontext c2 t)
  | R_mulC x c => R_mul x (evalRcontext c t)
  end.

(** ** Equational Reasoning *)
Inductive R_eqMALG : Rterm -> Rterm -> Type :=
(** equational rules *)
| R_refl t : R_eqMALG t t
| R_trans t1 t2 t3 : R_eqMALG t1 t2 -> R_eqMALG t2 t3 -> R_eqMALG t1 t3
| R_ctxt c t1 t2 : R_eqMALG t1 t2 -> R_eqMALG (evalRcontext c t1) (evalRcontext c t2)
| R_sym t1 t2 : R_eqMALG t1 t2 -> R_eqMALG t2 t1
| R_subs_r t1 t2 n t : R_eqMALG t1 t2 -> R_eqMALG (Rsubs t1 n t) (Rsubs t2 n t)
(** vector space axioms *)
| R_asso_plus t1 t2 t3 : R_eqMALG (t1 +R (t2 +R t3)) ((t1 +R t2) +R t3)
| R_commu_plus t1 t2 : R_eqMALG (t1 +R t2) (t2 +R t1)
| R_neutral_plus t : R_eqMALG (t +R R_zero) t
| R_opp_plus t : R_eqMALG (t -R t) R_zero
| R_mul_1 t  : R_eqMALG (1 *R t) t
| R_mul_assoc x y t : R_eqMALG (x *R (y *R t)) ((x * y) *R t)
| R_mul_distri_term x t1 t2 : R_eqMALG (x *R (t1 +R t2)) ((x *R t1) +R (x *R t2))
| R_mul_distri_coeff x y t : R_eqMALG ((x + y) *R t) ((x *R t) +R (y *R t))
(** lattice axioms *)
| R_asso_max t1 t2 t3 : R_eqMALG (R_max t1 (R_max t2 t3)) (R_max (R_max t1 t2) t3)
| R_commu_max t1 t2 : R_eqMALG (R_max t1 t2) (R_max t2 t1)
| R_abso_max t1 t2 : R_eqMALG (R_max t1 (R_min t1 t2)) t1
| R_asso_min t1 t2 t3 : R_eqMALG (R_min t1 (R_min t2 t3)) (R_min (R_min t1 t2) t3)
| R_commu_min t1 t2 : R_eqMALG (R_min t1 t2) (R_min t2 t1)
| R_abso_min t1 t2 : R_eqMALG (R_min t1 (R_max t1 t2)) t1
(** compability axiom *)
| R_compa_R_plus_ax t1 t2 t3 : R_eqMALG (R_min (R_plus (R_min t1 t2) t3) (R_plus t2 t3)) (R_plus (R_min t1 t2) t3)
| R_compa_mul_ax r t : 0 <= r -> R_eqMALG (R_min R_zero (R_mul r (R_max t R_zero))) R_zero.

Notation "A =R= B" := (R_eqMALG A B) (at level 90, no associativity).
Notation "A <R= B" := (R_eqMALG (R_min A B) A) (at level 90, no associativity).

(** *** =R= is an equivalence relation **)

Instance R_eqMALG_Equivalence : Equivalence R_eqMALG | 10 := {
  Equivalence_Reflexive := R_refl ;
  Equivalence_Symmetric := R_sym ;
  Equivalence_Transitive := R_trans }.

(** *** Proofs of a equalities *)

Hint Constructors R_eqMALG : core.

Lemma cong_S : forall A B, A = B -> A =R= B.
Proof.
  intros A B eq.
  subst.
  reflexivity.
Qed.
Hint Resolve cong_S : core.

Lemma plus_left : forall A B C, A =R= C -> A +R B =R= C +R B.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_plusC R_hole (R_TC B))).
  apply eq.
Qed.

Lemma plus_right : forall A B C, B =R= C -> A +R B =R= A +R C.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_plusC (R_TC A) R_hole)).
  apply eq.
Qed.

Lemma plus_cong : forall A B C D, A =R= B -> C =R= D -> A +R C =R= B +R D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A +R D); [apply plus_right | apply plus_left]; assumption.
Qed.

Global Instance plus_cong_instance : Proper (R_eqMALG ==> R_eqMALG ==> R_eqMALG) R_plus | 10.
Proof. repeat intro; now apply plus_cong. Qed.

Lemma max_left : forall A B C, A =R= C -> A \/R B =R= C \/R B.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_maxC R_hole (R_TC B))).
  apply eq.
Qed.

Lemma max_right : forall A B C, B =R= C -> A \/R B =R= A \/R C.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_maxC (R_TC A) R_hole)).
  apply eq.
Qed.

Lemma max_cong : forall A B C D, A =R= B -> C =R= D -> A \/R C =R= B \/R D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A \/R D); [apply max_right | apply max_left]; assumption.
Qed.

Global Instance max_cong_instance : Proper (R_eqMALG ==> R_eqMALG ==> R_eqMALG) R_max | 10.
Proof. repeat intro; now apply max_cong. Qed.

Lemma min_left : forall A B C, A =R= C -> A /\R B =R= C /\R B.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_minC R_hole (R_TC B))).
  apply eq.
Qed.

Lemma min_right : forall A B C, B =R= C -> A /\R B =R= A /\R C.
Proof.
  intros A B C eq.
  apply (@R_ctxt (R_minC (R_TC A) R_hole)).
  apply eq.
Qed.

Lemma R_mul_left : forall x y A , x = y -> R_mul x A =R= R_mul y A.
Proof.
  intros x y A eq.
  rewrite eq.
  auto.
Qed.

Lemma min_cong : forall A B C D, A =R= B -> C =R= D -> A /\R C =R= B /\R D.
Proof.
  intros A B C D eq1 eq2.
  transitivity (A /\R D); [apply min_right | apply min_left]; assumption.
Qed.

Global Instance min_cong_instance : Proper (R_eqMALG ==> R_eqMALG ==> R_eqMALG) R_min | 10.
Proof. repeat intro; now apply min_cong. Qed.

Lemma R_mul_right : forall x A B , A =R= B -> R_mul x A =R= R_mul x B.
Proof.
  intros x A B eq.
  apply (@R_ctxt (R_mulC x R_hole)).
  apply eq.
Qed.

Global Instance R_mul_right_instance x : Proper (R_eqMALG ==> R_eqMALG) (R_mul x) | 10.
Proof. repeat intro; now apply R_mul_right. Qed.

Lemma minus_cong : forall A B , A =R= B -> -R A =R= -R B.
Proof.
  intros A B eq.
  apply (@R_ctxt (R_mulC (-1) R_hole)).
  assumption.
Qed.

Global Instance minus_cong_instance : Proper (R_eqMALG ==> R_eqMALG) (R_mul (-1)) | 10.
Proof. repeat intro; now apply minus_cong. Qed.

Hint Resolve plus_left plus_right max_left max_right min_left min_right minus_cong R_mul_left R_mul_right : core.

Lemma evalContext_cong : forall c t1 t2, t1 =R= t2 -> evalRcontext c t1 =R= evalRcontext c t2.
Proof.
  induction c; simpl; auto.
  all:intros t1 t2 eq; specialize (IHc1 t1 t2 eq); specialize (IHc2 t1 t2 eq); rewrite IHc1 ; now rewrite IHc2.
Qed.

Global Instance evalContext_cong_instance c : Proper (R_eqMALG ==> R_eqMALG) (evalRcontext c) | 10.
Proof. repeat intro; now apply evalContext_cong. Qed.

Lemma leq_compa_plus : forall A B C, (A /\R B) +R C <R= B +R C.
Proof.
  intros A B C.
  auto.
Qed.

Hint Resolve leq_compa_plus : Rsem_solver.

Lemma minus_distri : forall A B, -R (A +R B) =R= (-R A) +R (-R B).
Proof.
  intros A B.
  auto.
Qed.

Hint Resolve minus_distri : Rsem_solver.

Lemma minus_R_zero : R_zero =R= -R R_zero.
Proof.
  rewrite <- (R_neutral_plus ((-1) *R R_zero)).
  rewrite R_commu_plus.
  auto.
Qed.

Lemma minus_minus : forall A , -R (-R A) =R= A.
Proof with auto.
  intro A.
  rewrite<- R_neutral_plus.
  rewrite<- (R_opp_plus A).
  rewrite (R_commu_plus A (-R A)).
  rewrite R_asso_plus.
  rewrite (R_commu_plus (-R (-R A)) (-R A)).
  rewrite R_opp_plus.
  now rewrite R_commu_plus.
Qed.

Hint Resolve minus_R_zero : Rsem_solver.
Hint Resolve minus_minus : Rsem_solver.

Lemma leq_antisym : forall A B, A <R= B -> B <R= A -> A =R= B.
Proof with auto.
  intros A B eq1 eq2.
  apply R_trans with (B /\R A)...
  apply R_trans with (A /\R B)...
Qed.

Lemma leq_cong_l : forall A A' B, A =R= A' -> A' <R= B -> A <R= B.
Proof with auto.
  intros A A' B eq leq.
  apply R_trans with (A' /\R B)...
  apply R_trans with A'...
Qed.

Lemma leq_cong_r : forall A B B', B =R= B' -> A <R= B' -> A <R= B.
Proof with auto.
  intros A B B' eq leq.
  apply R_trans with (A /\R B')...
Qed.

Lemma leq_R_trans : forall A B C, A <R= B -> B <R= C -> A <R= C.
Proof with auto.
  intros A B C leq1 leq2.
  apply R_trans with ((A /\R B) /\R C)...
  apply R_trans with (A /\R (B /\R C))...
  apply R_trans with (A /\R B)...
Qed.

Lemma leq_plus : forall A B C, A <R= B -> (A +R C) <R= (B +R C).
Proof with auto.
  intros A B C leq.
  apply leq_cong_l with ((A /\R B) +R C)...
Qed.

Hint Resolve leq_plus : Rsem_solver.

Lemma min_max : forall A B , (A /\R B) =R= A -> (A \/R B) =R= B.
Proof with auto.
  intros A B eq.
  apply R_trans with ((A /\R B) \/R B)...
  apply R_trans with ((B /\R A) \/R B)...
  apply R_trans with (B \/R (B /\R A))...
Qed.

Lemma max_min : forall A B , (A \/R B) =R= A -> (A /\R B) =R= B.
Proof with auto.
  intros A B eq.
  apply R_trans with ((A \/R B) /\R B)...
  apply R_trans with ((B \/R A) /\R B)...
  apply R_trans with (B /\R (B \/R A))...
Qed.

Hint Resolve max_min min_max : Rsem_solver.

Lemma leq_refl_cong : forall A B, ((A /\R A) /\R B) =R= A /\R B.
Proof with auto with *.
  intros A B.
  apply R_trans with (A /\R (A /\R B))...
Qed.

Lemma leq_refl : forall A , A /\R A =R= A.
Proof with auto.
  intro A.
  apply R_trans with (A /\R (A /\R (A \/R A)))...
  apply R_trans with ((A /\R A) /\R (A \/R A))...
  apply R_trans with (A /\R (A \/R A)); auto using leq_refl_cong.
Qed.

Hint Resolve leq_refl : Rsem_solver.

Lemma leq_min : forall A B C, A <R= B -> A <R= C -> A <R= (B /\R C).
Proof with auto.
  intros A B C leq1 leq2.
  apply R_trans with ((A /\R B) /\R C)...
  apply R_trans with (A /\R C)...
Qed.

Lemma leq_max : forall A B , A <R= (A \/R B).
Proof with auto.
  intros A B.
  auto.
Qed.

Lemma min_leq : forall A B, (A /\R B) <R= A.
Proof with auto with *.
  intros A B.
  apply R_trans with (A /\R (A /\R B))...
Qed.

Lemma max_leq : forall A B C, A <R= C -> B <R= C -> (A \/R B) <R= C.
Proof with auto with *.
  intros A B C leq1 leq2.
  apply R_trans with (C /\R (A \/R B))...
  apply max_min.
  apply R_trans with ((A \/R B) \/R C)...
  apply R_trans with (A \/R (B \/R C))...
  apply R_trans with (A \/R C)...
Qed.

Hint Resolve leq_max min_leq min_leq max_leq : Rsem_solver.

Lemma leq_plus_left : forall A B C, A <R= B -R C -> A +R C <R= B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_r with (B +R (-R C) +R C)...
  apply R_trans with (B +R ((-R C) +R C))...
  apply R_trans with (B +R (C -R C))...
  apply R_trans with (B +R R_zero)...
Qed.

Lemma leq_plus_right : forall A B C, A -R B <R= C -> A <R= C +R B.
Proof with auto with *.
  intros A B C leq.
  apply leq_cong_l with ( A -R B +R B)...
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (B -R B))...
  apply R_trans with (A +R ((-R B) +R B))...
Qed.

Lemma leq_minus_left : forall A B C, A <R= B +R C -> A -R C <R= B.
Proof with auto.
  intros A B C leq.
  apply leq_plus_left...
  apply R_trans with (A /\R (B +R C)); auto using minus_minus.
Qed.

Lemma leq_minus_right : forall A B C , A +R C <R= B -> A <R= B -R C.
Proof with auto.
  intros A B C leq.
  apply leq_plus_right.
  apply R_trans with ((A +R C) /\R B); auto using minus_minus.
  apply R_trans with (A +R C); auto using minus_minus.
Qed.

Lemma max_plus : forall A B C, ((A \/R B) +R C) =R= (A +R C) \/R (B +R C).
Proof with auto.
  intros A B C.
  apply leq_antisym.
  - apply leq_plus_left.
    apply max_leq.
    + apply leq_minus_right...
    + apply leq_minus_right...
      apply R_trans with ((B +R C) /\R ((B +R C) \/R (A +R C)))...
  - apply max_leq; auto using leq_plus.
    apply leq_plus_right.
    apply leq_cong_l with B.
      * apply R_trans with (B +R (C -R C))...
        apply R_trans with (B +R R_zero)...
      * apply leq_cong_r with (B \/R A)...
Qed.

Hint Resolve max_plus : Rsem_solver.

Lemma minus_reverse_leq : forall A B, B <R= A -> (-R A) <R= (-R B).
Proof with auto.
  intros A B leq.
  apply leq_cong_r with (-R B +R R_zero)...
  apply leq_cong_r with (R_zero -R B)...
  apply leq_minus_right.
  apply leq_cong_l with (B -R A)...
  apply leq_minus_left.
  apply leq_cong_r with (A +R R_zero)...
  apply leq_cong_r with A...
Qed.

Hint Resolve minus_reverse_leq : Rsem_solver.

Lemma minus_min_max : forall A B, -R (A /\R B) =R= (-R A) \/R (-R B).
Proof with auto with Rsem_solver.
  intros A B.
  apply leq_antisym.
  - apply leq_cong_r with (-R (-R ((-R A) \/R (-R B))))...
    apply minus_reverse_leq.
    apply leq_min.
    + apply leq_cong_r with (-R (-R A))...
    + apply leq_cong_r with (-R (-R B))...
      apply leq_cong_l with (-R (-R B \/R -R A))...
  - apply max_leq.
    + apply minus_reverse_leq...
    + apply leq_cong_r with (-R (B /\R A))...
Qed.

Lemma min_leq_max : forall A B, A /\R B <R= A \/R B.
Proof with auto with Rsem_solver.
  intros A B.
  apply leq_R_trans with A...
Qed.

Hint Resolve minus_min_max min_leq_max : Rsem_solver.

Lemma minus_inj : forall A B, -R A =R= -R B -> A =R= B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (-R (-R A))...
  apply R_trans with (-R (-R B))...
Qed.

Lemma leq_plus_cong : forall A B C D, A <R= B -> C <R= D -> A +R C <R= B +R D.
Proof with auto with Rsem_solver.
  intros A B C D leq1 leq2.
  apply leq_R_trans with (B +R C)...
  apply leq_cong_l with (C +R B)...
  apply leq_cong_r with (D +R B)...
Qed.

Hint Resolve leq_plus_cong : Rsem_solver.

Lemma cond_leq : forall A B, R_zero <R= (A -R B) -> B <R= A.
Proof with auto with Rsem_solver.
  intros A B Hleq.
  apply leq_cong_r with ((A -R B) +R B).
  { apply R_trans with (A +R R_zero)...
    apply R_trans with (A +R (B -R B))...
    apply R_trans with (A +R ((-R B) +R B))... }
  apply leq_cong_l with (R_zero +R B)...
  apply R_trans with (B +R R_zero)...
Qed.

Lemma cond_leq_inv : forall A B, B <R= A -> R_zero <R= (A -R B).
Proof with auto with Rsem_solver.
  intros A B Hleq.
  apply leq_cong_l with (B -R B)...
Qed.

Lemma eq_minus : forall A B, A =R= B -> A -R B =R= R_zero.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (B -R B)...
Qed.

Hint Resolve eq_minus : Rsem_solver.

Lemma minus_eq : forall A B, A -R B =R= R_zero -> A =R= B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (B -R B))...
  apply R_trans with (A +R ((-R B) +R B))...
  apply R_trans with (A -R B +R B)...
  apply R_trans with (R_zero +R B)...
  apply R_trans with (B +R R_zero)...
Qed.

Lemma R_minus_mul : forall r A, -R (r *R A) =R= r *R (-R A).
Proof with auto with Rsem_solver.
  intros r A.
  rewrite R_mul_assoc.
  replace (-1 * r) with (r * -1) by lra.
  rewrite R_mul_assoc.
  reflexivity.
Qed.

Hint Resolve R_minus_mul : Rsem_solver.

Lemma R_mul_compa : forall r A B, (0 <= r) -> A <R= B -> (r *R A) <R= (r *R B).
Proof with auto with Rsem_solver.
  intros r A B Hleqr HleqAB.
  apply cond_leq.
  apply leq_cong_r with ((r *R ((B -R A) \/R R_zero))).
  { apply R_trans with ((r *R B) +R (r *R (-R A)))...
    apply R_trans with (r *R (B -R A))...
    apply R_mul_right.
    apply R_sym.
    apply R_trans with (R_zero \/R (B -R A))...
    apply min_max.
    apply cond_leq_inv...
  }
  apply R_compa_mul_ax...
Qed.

Hint Resolve R_mul_compa : Rsem_solver.

Lemma R_mul_0 :  forall r, r *R R_zero =R= R_zero.
Proof with auto with Rsem_solver.
  intro r.
  transitivity (r *R (R_zero +R R_zero))...
  transitivity (r *R R_zero +R r *R R_zero)...
  transitivity (r *R R_zero +R r *R (-R R_zero))...
  transitivity (r *R R_zero +R (-R (r *R R_zero)))...
Qed.

Hint Resolve R_mul_0 : Rsem_solver.

Lemma no_div_R_zero : forall r A, r <> 0 -> r *R A =R= R_zero -> A =R= R_zero.
Proof with auto with Rsem_solver.
  intros r A Hr eq.
  transitivity (1 *R A)...
  transitivity ((/ r * r) *R A)...
  { apply R_mul_left.
    symmetry.
    apply Rinv_l... }
  apply R_trans with ((/ r) *R (r *R A))...
  apply R_trans with ((/ r) *R R_zero)...
Qed.

Lemma R_mul_distri_minus : forall k A B, (k *R A) -R (k *R B) =R= k *R (A -R B).
Proof with auto with Rsem_solver.
  intros k A B.
  apply R_trans with ((k *R A) +R (k *R (-R B)))...
Qed.

Lemma minus_max_min : forall A B, -R (A \/R B) =R= (-R A) /\R (-R B).
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with (-R (A \/R (-R (-R B))))...
  apply R_trans with (-R ((-R (-R A)) \/R (-R (-R B))))...
  apply R_trans with (-R (-R ((-R A) /\R (-R B))))...
Qed.

Hint Resolve R_mul_distri_minus minus_max_min : Rsem_solver.

Lemma R_zero_leq_pos : forall A , R_zero <R= R_pos A.
Proof with auto with Rsem_solver.
  intro A.
  apply leq_cong_r with (R_zero \/R A)...
Qed.

Lemma R_zero_leq_neg : forall A , R_zero <R= R_neg A.
Proof with auto with Rsem_solver.
  intro A.
  apply leq_cong_r with (R_zero \/R (-R A))...
Qed.

Hint Resolve R_zero_leq_pos R_zero_leq_neg : Rsem_solver.

Lemma eq_minus_right : forall A B C, A +R C =R= B -> A =R= B -R C.
Proof with auto with Rsem_solver.
  intros A B C eq.
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (C -R C))...
  apply R_trans with ((A +R C) -R C)...
Qed.

Lemma eq_plus_right : forall A B C, A -R C =R= B -> A =R= B +R C.
Proof with auto with Rsem_solver.
  intros A B C eq.
  apply R_trans with (A +R R_zero)...
  apply R_trans with (A +R (C -R C))...
  apply R_trans with (A +R ((-R C) +R C))...
  apply R_trans with ((A -R C) +R C)...
Qed.

Lemma decomp_pos_neg : forall A, A =R= (R_pos A) -R (R_neg A).
Proof with auto with Rsem_solver.
  intros A.
  apply eq_minus_right.
  apply R_trans with (A \/R (A -R A))...
  apply R_trans with ((A +R R_zero) \/R (A -R A))...
  apply R_trans with ((R_zero +R A) \/R (A -R A))...
  apply R_trans with ((A -R A) \/R (R_zero +R A))...
  apply R_trans with (((-R A) +R A) \/R (R_zero +R A))...
  apply R_trans with (R_neg A +R A)...
Qed.

Hint Resolve decomp_pos_neg : Rsem_solver.

Lemma pos_neg : forall A, R_pos A =R= A +R (R_neg A).
Proof.
  intros A.
  apply R_trans with ((R_pos A -R R_neg A) +R R_neg A); auto using eq_plus_right with Rsem_solver.
Qed.

Lemma neg_pos : forall A , R_neg A =R= (R_pos A) -R A.
Proof with auto with Rsem_solver.
  intros A.
  apply eq_minus_right...
  apply R_trans with (A +R R_neg A); auto using eq_plus_right with Rsem_solver.
Qed.

Hint Resolve pos_neg neg_pos : Rsem_solver.

Lemma min_plus : forall A B C, (A /\R B) +R C =R= (A +R C) /\R (B +R C).
Proof with auto with Rsem_solver.
  intros A B C.
  apply R_trans with (-R (-R ((A +R C) /\R (B +R C))))...
  apply R_trans with (-R ((-R (A +R C)) \/R (-R (B +R C))))...
  apply R_trans with (-R (((-R A) -R C) \/R ((-R (B +R C)))))...
  apply R_trans with (-R (((-R A) -R C) \/R (((-R B) -R C))))...
  apply R_trans with (-R (((-R A) \/R ((-R B))) -R C))...
  apply R_trans with ((-R (((-R A) \/R ((-R B))))) -R (-R C))...
  apply R_trans with ((-R (((-R A) \/R ((-R B))))) +R C)...
  apply R_trans with (((-R (-R A)) /\R ((-R (-R B)))) +R C)...
  apply R_trans with ((A /\R ((-R (-R B)))) +R C)...
Qed.

Hint Resolve min_plus : Rsem_solver.

Lemma min_pos_neg : forall A, (R_pos A) /\R (R_neg A) =R= R_zero.
Proof with auto with Rsem_solver.
  intros A.
  apply R_trans with ((A +R (R_neg A)) /\R (R_neg A))...
  apply R_trans with ((A +R (R_neg A)) /\R (R_neg A +R R_zero))...
  apply R_trans with ((A +R (R_neg A)) /\R (R_zero +R R_neg A))...
  apply R_trans with ((A /\R R_zero) +R R_neg A)...
  apply R_trans with ( (-R (-R (A /\R R_zero))) +R R_neg A)...
  apply R_trans with ( (-R ((-R A) \/R (-R R_zero))) +R R_neg A)...
  apply R_trans with ( (-R (R_neg A)) +R R_neg A)...
  apply R_trans with (R_neg A -R R_neg A)...
Qed.

Hint Resolve min_pos_neg : Rsem_solver.

Lemma cond_R_zero_leq_max : forall A B,
    (A \/R B) =R= (R_pos A \/R R_pos B) -> R_zero <R= A \/R B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with ((A \/R B) /\R R_zero)...
  apply max_min.
  apply R_trans with ((A \/R B) \/R (R_zero \/R R_zero))...
  apply R_trans with (A \/R (B \/R (R_zero \/R R_zero)))...
  apply R_trans with (A \/R (R_pos B \/R R_zero))...
  apply R_trans with (A \/R (R_zero \/R R_pos B))...
  apply R_trans with (R_pos A \/R R_pos B)...
Qed.

Lemma cond_eq_pos : forall A B,
    R_zero <R= A \/R B -> (A \/R B) =R= (R_pos A \/R R_pos B).
Proof with auto with Rsem_solver.
  intros A B eq.
  apply R_trans with (A \/R (R_zero \/R R_pos B))...
  apply R_trans with (A \/R (R_pos B \/R R_zero))...
  apply R_trans with (A \/R (B \/R (R_zero \/R R_zero)))...
  apply R_trans with ((A \/R B) \/R (R_zero \/R R_zero))...
  apply R_trans with (A \/R B \/R R_zero)...
  apply R_trans with (R_zero \/R (A \/R B))...
Qed.

Lemma max_pos : forall A B, A \/R B =R= (R_pos (A -R B)) +R B.
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with ((A +R R_zero) \/R B)...
  apply R_trans with ((A +R (B -R B)) \/R B)...
  apply R_trans with ((A +R ((-R B) +R B)) \/R B)...
  apply R_trans with ((A +R (-R B) +R B) \/R B)...
  apply R_trans with ((A +R (-R B) +R B) \/R (B +R R_zero))...
  apply R_trans with ((A +R (-R B) +R B) \/R (R_zero +R B))...
Qed.

Hint Resolve max_pos : Rsem_solver.

Lemma min_pos : forall A B, A /\R B =R= A -R (R_pos (A -R B)).
Proof with auto with Rsem_solver.
  intros A B.
  apply eq_minus_right.
  apply R_trans with ((R_pos (A -R B)) +R (A /\R B))...
  apply R_sym.
  apply eq_plus_right.
  apply R_trans with (A +R ((-R A) \/R (-R B)))...
  apply R_trans with (((-R A) \/R (-R B)) +R A)...
  apply R_trans with (((-R A) +R A) \/R ((-R B) +R A))...
  apply R_trans with ((A -R A) \/R ((-R B) +R A))...
  apply R_trans with (R_zero \/R ((-R B) +R A))...
  apply R_trans with (R_zero \/R (A -R B))...
Qed.

Hint Resolve min_pos : Rsem_solver.

Lemma min_max_plus : forall A B, (A \/R B) +R (A /\R B) =R= A +R B.
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with (((R_pos (A -R B)) +R B) +R (A /\R B))...
  apply R_trans with (((R_pos (A -R B)) +R B) +R (A -R (R_pos (A -R B))))...
  apply R_trans with ((B +R (R_pos (A -R B))) +R (A -R (R_pos (A -R B))))...
  apply R_trans with (B +R ((R_pos (A -R B)) +R (A -R (R_pos (A -R B)))))...
  apply R_trans with (B +R ((R_pos (A -R B)) +R ((-R (R_pos (A -R B))) +R A)))...
  apply R_trans with (B +R ((R_pos (A -R B)) +R (-R (R_pos (A -R B))) +R A))...
  apply R_trans with (B +R (R_zero +R A))...
  apply R_trans with (B +R (A +R R_zero))...
  apply R_trans with (B +R A)...
Qed.

Hint Resolve min_max_plus : Rsem_solver.

Lemma max_distri_min : forall A B C, (A /\R B) \/R C =R= (A \/R C) /\R (B \/R C).
Proof with auto with Rsem_solver.
  intros A B C.
  remember ((A \/R C) /\R (B \/R C)) as m.
  apply leq_antisym.
  - apply leq_cong_r with (A \/R C /\R B \/R C)...
    apply leq_min.
    + apply max_leq.
      * apply leq_R_trans with A...
      * apply leq_cong_r with (C \/R A)...
    + apply max_leq...
      * apply leq_R_trans with B...
        apply leq_cong_l with (B /\R A)...
      * apply leq_cong_r with (C \/R B)...
  - apply leq_cong_r with ((A /\R B) -R ((-R C) +R ((A /\R B) /\R C)))...
    + apply R_trans with ((A /\R B) +R ((-R (-R C)) -R ((A /\R B) /\R C)))...
      apply R_trans with ((A /\R B) +R (C -R ((A /\R B) /\R C)))...
      apply R_trans with (((A /\R B) +R C) -R ((A /\R B) /\R C)); auto using eq_minus_right with Rsem_solver.
    + apply leq_minus_right...
      apply leq_min...
      * apply leq_cong_l with ((m +R ((A /\R B) /\R C)) -R C)...
        ** apply R_trans with (m +R (((A /\R B) /\R C) -R C))...
        ** apply leq_cong_r with ((A +R C) -R C); auto using eq_minus_right with Rsem_solver.
           apply leq_plus.
           apply leq_cong_r with ((A \/R C) +R (A /\R C))...
           apply leq_R_trans with (m +R (A /\R C))...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A /\R (B /\R C))...
               apply leq_cong_l with (A /\R (C /\R B))...
               apply leq_cong_l with (A /\R C /\R B)...
           *** apply leq_plus_cong...
               apply leq_cong_l with (A \/R C /\R B \/R C)...
      * apply leq_cong_l with (m +R ((A /\R B /\R C) -R C))...
        apply leq_cong_l with ((m +R (A /\R B /\R C)) -R C)...
        apply leq_cong_r with (B +R R_zero)...
        apply leq_cong_r with (B +R (C -R C))...
        apply leq_cong_r with ((B +R C) -R C)...
        apply leq_plus...
        apply leq_cong_r with ((B \/R C) +R (B /\R C))...
        apply leq_plus_cong...
        apply leq_cong_l with (A \/R C /\R B \/R C)...
        ** apply leq_cong_l with (B \/R C /\R A \/R C)...
        ** apply leq_cong_l with (A /\R (B /\R C))...
           apply leq_cong_l with ((B /\R C) /\R A)...
Qed.

Hint Resolve max_distri_min : Rsem_solver.

Lemma min_distri_max : forall A B C, (A \/R B) /\R C =R= (A /\R C) \/R (B /\R C).
Proof with auto with Rsem_solver.
  intros A B C.
  apply R_trans with (-R (-R (A \/R B /\R C)))...
  apply R_trans with (-R ((-R (A \/R B) \/R (-R C))))...
  apply R_trans with (-R (((-R A) /\R (-R B)) \/R (-R C)))...
  apply R_trans with (-R (((-R A) \/R (-R C)) /\R ((-R B) \/R (-R C))))...
  apply R_trans with ((-R ((-R A) \/R (-R C))) \/R (-R ((-R B) \/R (-R C))))...
  apply R_trans with (((-R (-R A)) /\R (-R (-R C))) \/R (-R ((-R B) \/R (-R C))))...
  apply R_trans with (((-R (-R A)) /\R (-R (-R C))) \/R ((-R (-R B)) /\R (-R (-R C))))...
  apply R_trans with ((A /\R (-R (-R C))) \/R ((-R (-R B)) /\R (-R (-R C))))...
  apply R_trans with ((A /\R C) \/R ((-R (-R B)) /\R (-R (-R C))))...
  apply R_trans with ((A /\R C) \/R (B /\R (-R (-R C))))...
Qed.

Hint Resolve min_distri_max : Rsem_solver.

Lemma decomp_max_pos_neg : forall A B, A \/R B =R= ((R_pos A) \/R (R_pos B)) -R ((R_neg A) /\R (R_neg B)).
Proof with auto with Rsem_solver.
  intros A B.
  apply R_trans with (R_pos (A \/R B) -R (R_neg (A \/R B)))...
  apply R_trans with ((R_pos A \/R R_pos B) -R (R_neg (A \/R B))).
  - apply (@R_ctxt (R_plusC R_hole (R_mulC (-1) (R_TC (R_neg (A \/R B)))))).
    apply R_trans with (A \/R B \/R (R_zero \/R R_zero))...
    apply R_trans with (A \/R (B \/R R_pos R_zero))...
    apply R_trans with (A \/R (R_pos B \/R R_zero))...
    apply R_trans with (A \/R (R_zero \/R R_pos B))...
  - apply R_trans with ((R_pos A \/R R_pos B) -R (((-R A) /\R (-R B)) \/R R_zero))...
Qed.

Hint Resolve decomp_max_pos_neg : Rsem_solver.

Lemma cond_R_zero_leq_max_2 : forall A B, (R_neg A) /\R (R_neg B) =R= R_zero -> R_zero <R= A \/R B.
Proof with auto with Rsem_solver.
  intros A B eq.
  apply cond_R_zero_leq_max...
  apply R_trans with ((R_pos A \/R R_pos B) +R R_zero)...
  apply R_trans with ((R_pos A \/R R_pos B) -R R_zero)...
  apply R_trans with ((R_pos A \/R R_pos B) -R (R_neg A /\R R_neg B))...
Qed.

Lemma cond_min_R_neg_eq_R_zero : forall A B, R_zero <R= A \/R B -> (R_neg A) /\R (R_neg B) =R= R_zero.
Proof with auto with Rsem_solver.
  intros A B leq.
  apply R_trans with (((R_pos A) \/R (R_pos B)) -R (A \/R B)); auto using eq_minus_right, cond_eq_pos with Rsem_solver.
  apply eq_minus_right...
  apply R_trans with ((A \/R B) +R (R_neg A /\R R_neg B)); auto using eq_plus_right with Rsem_solver.
Qed.

Lemma R_zero_leq_abs : forall A, R_zero <R= R_abs A.
Proof with auto with Rsem_solver.
  intro A.
  apply cond_R_zero_leq_max_2.
  apply R_trans with ((R_neg A) /\R (R_pos A))...
  apply R_trans with ((R_pos A) /\R (R_neg A))...
Qed.

Hint Resolve R_zero_leq_abs : Rsem_solver.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Several results to ease the definition and the analysis of
   (well-founded) recursive functions *)

Require Import Common.
Set Implicit Arguments.

(** Trick to compute with well-founded recursions: lazily add 2^n
   Acc_intro constructors in front of a well_foundedness proof, so
   that the actual proof is never reached in practise *)
Fixpoint guard A (R: A -> A -> Prop) n (wfR: well_founded R): well_founded R :=
  match n with
    | 0 => wfR
    | S n => fun x => Acc_intro x (fun y _ => guard  n (guard n wfR) y)
  end.

(** Lexicographic product of two well-founded relations *)
Section lexico.
  Variables A B: Type.
  Variable R: relation A.
  Variable S: relation B.
  Inductive lexico: relation (A*B) :=
    | lexico_left: forall a a' b b', R a' a -> lexico (a',b') (a,b)
    | lexico_right: forall a b b', S b' b -> lexico (a,b') (a,b)
      .
  Hypothesis HR: well_founded R.
  Hypothesis HS: well_founded S.
  Theorem lexico_wf: well_founded lexico.
  Proof.
    intros [a b]. revert b.
    induction a as [a IHa] using (well_founded_induction HR).
    induction b as [b IHb] using (well_founded_induction HS).
    constructor. intros [a' b'] H. inversion_clear H; auto.
  Qed.
End lexico.

(** A relation contained in a well-founded relation is well-founded *)
Section wf_incl.
  Variable A: Type.
  Variable S: relation A.
  Hypothesis HS: well_founded S.
  Variable R: relation A.
  Hypothesis H: forall a' a, R a' a -> S a' a.
  Theorem incl_wf: well_founded R.
  Proof.
    intros a. induction a as [a IHa] using (well_founded_induction HS).
    constructor. eauto.
  Qed.
End wf_incl.

(** Equivalent of [well_founded_ltof], using an underlying well-founded relation *)
Section wf_of.
  Variables U V: Type.
  Variable f: U -> V.
  Variable R: relation V.
  Hypothesis HR: well_founded R.
  Definition rel_of: relation U := fun a' a => R (f a') (f a).
  Theorem rel_of_wf: well_founded rel_of.
  Proof.
    unfold rel_of.
    intro a. remember (f a) as fa. revert a Heqfa.
    induction fa as [fa IHa] using (well_founded_induction HR).
    constructor. intros a' H. subst. eauto.
  Qed.
End wf_of.

(** Similarly, in the other direction  *)
Section wf_to.
  Variables U V: Type.
  Variable f: U -> V.
  Variable R: relation U.
  Inductive rel_to: relation V :=
    rel_to_intro: forall a' a, R a' a -> rel_to (f a') (f a).
  Hypothesis HR: well_founded rel_to.
  Theorem rel_to_wf: well_founded R.
  Proof.
    intro a. remember (f a) as fa. revert a Heqfa.
    induction fa as [fa IHa] using (well_founded_induction HR).
    constructor. intros a' H. subst. eapply IHa; trivial. constructor. trivial.
  Qed.
End wf_to.

(** Combination of the above reductions : reduction to a lexicographic product of two well-founded relations *)
Section wf_lexico_incl.
  Variables U A B: Type.
  Variable f: U -> A*B.
  Variable RA: relation A.
  Variable RB: relation B.
  Hypothesis HRA: well_founded RA.
  Hypothesis HRB: well_founded RB.
  Variable R: relation U.
  Hypothesis H: forall u' u, R u' u -> lexico RA RB (f u') (f u).
  Theorem lexico_incl_wf: well_founded R.
  Proof.
    apply (rel_to_wf (f:=f)). eapply incl_wf. apply lexico_wf; eassumption.
    intros [a' b'] [a b] [u' u Hab]. auto.
  Qed.
End wf_lexico_incl.

(** Lazy partial fixpoint operators (lazy iterator):
    we use these functions to avoid the computation of a (2^n) worst-case
    bound which is never reached in practise *)
Section powerfix.

  Variables A B: Type.
  Notation Fun := (A -> B).

  (** the three following functions "iterate" their [f] argument lazily: iteration stops whenever [f]
     no longer makes recursive calls.
     - [powerfix' n f k] iterates [f] at most [(2^n-1)] times and then yields to [k]
     - [powerfix n f k] iterates [f] at most [(2^n)] times and then yields to [k]
     - [linearfix n f k] iterates [f] at most [n] times and then yields to [k]
     *)
  Fixpoint powerfix' n (f: Fun -> Fun) (k: Fun): Fun :=
    fun a => match n with O => k a | S n => f (powerfix' n f (powerfix' n f k)) a end.
  Definition powerfix n f k a := f (powerfix' n f k) a.
  Fixpoint linearfix n (f: Fun -> Fun) (k: Fun): Fun :=
    fun a => match n with O => k a | S n => f (linearfix n f k) a end.

  (** [power n = 2^n] *)
  Fixpoint power n := match n with O => 1 | S n => 2*power n end.

  Lemma power_positive: forall n, 0 < power n.
  Proof. induction n; simpl; lia. Qed.

  (** Characterisation of [powerfix] with [linearfix] *)
  Section linear_carac.

    Context {R} `{E: Equivalence B R}.
    Variable f: Fun -> Fun.
    (** the functional [f] as to use its first argument "in extension" *)
    Hypothesis Hf: Proper (pointwise_relation A R ==> @eq A ==> R) f.

    Instance linearfix_compat n:
      Proper (pointwise_relation A R ==> pointwise_relation A R) (linearfix n f).
    Proof.
      induction n; intros k k' H a; simpl.
       apply H.
       apply Hf; auto.
    Qed.

    Lemma linearfix_plus: forall n m k, pointwise_relation A R
      (linearfix n f (linearfix m f k)) (linearfix (n + m) f k).
    Proof.
      induction n; intros m k a; simpl.
       reflexivity.
       rewrite IHn. reflexivity.
    Qed.

    Instance powerfix'_compat n:
      Proper (pointwise_relation A R ==> pointwise_relation A R) (powerfix' n f).
    Proof.
      induction n; intros k k' H a; simpl.
       apply H.
       apply Hf; auto.
    Qed.

    Instance powerfix_compat n:
      Proper (pointwise_relation A R ==> pointwise_relation A R) (powerfix n f).
    Proof.
      intros k k' H. unfold powerfix. setoid_rewrite H. reflexivity.
    Qed.

    Lemma powerfix'_linearfix: forall n k,
      pointwise_relation A R (powerfix' n f k) (linearfix (pred (power n)) f k).
    Proof.
      induction n; intros; simpl; intro a.
       reflexivity.
       rewrite IHn. rewrite IHn.
       pose proof (power_positive n).
       replace (pred (power n + (power n + 0))) with (S (pred (power n) + pred (power n))) by lia.
       rewrite linearfix_plus.
       reflexivity.
    Qed.

    (** The expected characterisation  *)
    Theorem powerfix_linearfix: forall n k,
      pointwise_relation A R (powerfix n f k) (linearfix (power n) f k).
    Proof.
      intros. unfold powerfix. setoid_rewrite powerfix'_linearfix.
      generalize (power_positive n). destruct (power n).
       intro. lia_false.
       intro. reflexivity.
    Qed.

  End linear_carac.

  (** [powerfix_invariant] gives an induction principle for [powerfix], that does not care
     about the number of iterations -- in particular, the trivial "emptyfix" function :
     ([fun f k a => k a]) satisfies the same induction principle, so that this can only be
     used to reason about partial correctness. *)
  Section invariant.
    Variable P: Fun -> Prop.
    Hypothesis HP: forall k, P k -> P (fun a => k a).
    (* Alternative hypothesis: *)
    (* Hypothesis HP: Proper (pointwise_relation A (@eq B) ==> iff) P. *)
    Lemma powerfix'_invariant': forall n f g, (forall k, P k -> P (f k)) -> P g -> P (powerfix' n f g).
    Proof.
      induction n; intros f g Hf Hg; simpl; apply HP; auto.
    Qed.
    Lemma powerfix_invariant': forall n f g, (forall k, P k -> P (f k)) -> P g -> P (powerfix n f g).
    Proof.
      intros n f g Hf Hg. apply HP, Hf, powerfix'_invariant'; assumption.
    Qed.
  End invariant.

End powerfix.

(** Another way to construct well-founded relations: start with a well-founded one (e.g., the empty one),
   and progressively add pairs satisfying some acyclicity property w.r.t. the current relation *)
Require Relations.
Section add_pair.
  Import Relations.

  Variable T: Set.
  Definition add_pair i j R: relation T := fun s t => s=i /\ t=j \/ R s t.

  Lemma wf_add_pair: forall R, well_founded R ->
    forall i j, ~ clos_refl_trans T R j i -> well_founded (add_pair i j R).
  Proof.
    intros R Hwf i j Hij.

    assert (Hi: forall v, clos_refl_trans _ R v i -> Acc (add_pair i j R) v).
     induction v as [v IH] using (well_founded_induction Hwf); intros Hui.
     constructor. intros u [[-> ->]|Huv].
      elim Hij. assumption.
      apply IH. assumption.
      eauto using rt_trans, rt_step.

    intro v. induction v as [v IH] using (well_founded_induction Hwf).
    constructor. intros u [[-> ->] | Huv].
     apply Hi. constructor 2.
     apply IH. assumption.
  Qed.
End add_pair.

(** An induction principle for [Fix], which is less demanding than the corresponding results
   of the standard library (no additional hypothesis about [P] or [F]) *)
Section Fix_induction.
  Variable A: Type.
  Variable R: relation A.
  Hypothesis Hwf: well_founded R.
  Variable T: A -> Type.
  Variable F: forall x, (forall y, R y x -> T y) -> T x.
  Variable P: forall x, T x -> Prop.

  Hypothesis IH: forall x (G: forall y, R y x -> T y), (forall y (H: R y x), P (G y H)) -> P (F G).
  Theorem Fix_induction: forall x, P (Fix Hwf _ F x).
  Proof.
    unfold Fix. intro x. generalize (Hwf x) as Hx.
    induction x as [x IHwf] using (well_founded_induction Hwf); intros.
    rewrite <- Fix_F_eq. auto.
  Qed.
End Fix_induction.
Arguments Fix_induction [A R] Hwf [T F P].


(*
    Authors: Thierry Coquand, Vincent Siles
*)
From mathcomp Require Import ssreflect ssrnat seq ssrbool eqtype fintype choice.

Set Implicit Arguments.

Module Misc.

  Section Language.

    Variable char: finType.
    Definition word := seq char.
    Definition language := pred word.

  End Language.

  Lemma ltn_trans_tight m n p : m < n -> n < p -> m < p.-1.
  Proof.
    elim: p n m => [|p IHp ] n m.
      by [].
      move => H0. rewrite leq_eqVlt => /orP [].
      move/eqP => <-. exact: H0.
      rewrite ltnS => H1. move: (IHp _ _ H0 H1) => /=.
      case: p IHp H1 => [|p] IHp H1.
        by [].
          by exact: ltnW.
  Qed.

  Lemma ltn_trans_tight' m n p : m < n -> n < p.-1 -> m < p.-1.
  Proof. elim: p n m => [|p IHp ] n m.
           by [].
           move => H0. rewrite leq_eqVlt => /orP [].
           move/eqP => <-. apply: leqW. by [].
           move/leqW. apply: ltn_trans_tight. by apply: leqW.
  Qed.

  Lemma size_induction {X : Type} (f : X -> nat) (p: X ->Prop) :
    ( forall x, ( forall y, f y < f x -> p y) -> p x) -> forall x, p x.
  Proof. intros A x. apply A. induction (f x). by [].
         intros y B. apply A. intros z C. apply IHn.
         move: C B. apply: ltn_trans_tight. Qed.

End Misc.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_functor.examples.composition
     lax_transformation.lax_transformation
     general_category.

Lemma F_assoc_inv₁
       {C D : BiCategory}
       (F : LaxFunctor C D)
       `{is_pseudo _ _ F}
      {W X Y Z : C}
      (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : Fcomp₁_inv F h (g · f) ∘ (F ₂ assoc h g f)
    =
    (id₂ (F ₁ h) * Fcomp₁ F g f)
      ∘ assoc (F ₁ h) (F ₁ g) (F ₁ f)
      ∘ (Fcomp₁_inv F h g * id₂ (F ₁ f))
      ∘ Fcomp₁_inv F (h · g) f.
Proof.
  refine (vcomp_move_R_Mp _ _ _ _).
  rewrite <- !vcomp_assoc.
  refine (vcomp_move_L_pM _ _ _ _).
  refine (vcomp_move_L_pM _ _ _ _).
  symmetry.
  apply F_assoc.
Qed.

Lemma F_assoc_inv₂
       {C D : BiCategory}
       (F : LaxFunctor C D)
       `{is_pseudo _ _ F}
      {W X Y Z : C}
      (h : C⟦Y,Z⟧) (g : C⟦X,Y⟧) (f : C⟦W,X⟧)
  : (Fcomp₁_inv F (h · g) f)
      ∘ (F ₂ assoc_inv h g f) ∘ Fcomp₁ F h (g · f)
    =
    (Fcomp₁ F h g * id₂ (F ₁ f))
      ∘ assoc_inv (F ₁ h) (F ₁ g) (F ₁ f)
      ∘ id₂ (F ₁ h) * Fcomp₁_inv F g f.
Proof.
  refine (vcomp_move_R_Mp _ _ _ _).
  rewrite <- !vcomp_assoc.
  refine (vcomp_move_L_pM _ _ _ _).
  refine (vcomp_move_L_pM _ _ _ _).
  apply F_assoc.
Qed.

Section WhiskerL.
  Context `{Univalence}
          {C D E : BiCategory}
          {F₁ F₂ : LaxFunctor C D}.
  Variable (G : LaxFunctor D E)
           (σ : LaxTransformation F₁ F₂).
  Context `{is_pseudo _ _ G}.

  Definition whisker_L_d
    : LaxTransformation_d (lax_comp G F₁) (lax_comp G F₂).
  Proof.
    make_lax_transformation.
    - exact (fun X => G ₁ (σ X)).
    - intros X Y f ; cbn in *.
      exact ((Fcomp₁_inv G (σ Y) (F₁ ₁ f))
               ∘ (G ₂ (laxnaturality_of σ f))
               ∘ Fcomp₁ G (F₂ ₁ f) (σ X)).
  Defined.

  Definition whisker_L_d_is_lax
    : is_lax_transformation whisker_L_d.
  Proof.
    make_is_lax_transformation.
    - intros X Y f g α ; simpl in *.
      rewrite !vcomp_assoc.
      pose (Fcomp₂ G (F₂ ₂ α) (id₂ (σ X))) as p.
      rewrite Fmor₂_id₂ in p.
      rewrite p ; clear p.
      rewrite <- !vcomp_assoc.
      f_ap.
      rewrite <- (Fmor₂_id₂ G (σ Y)).
      rewrite <- (Fcomp₁_inv_naturality G (id₂ (σ Y)) (F₁ ₂ α)).
      rewrite !vcomp_assoc.
      f_ap.
      rewrite <- (Fmor₂_vcomp G (laxnaturality_of σ f) (id₂ (σ Y) * (F₁ ₂ α))).
      rewrite <- (Fmor₂_vcomp G ((F₂ ₂ α) * id₂ (σ X)) (laxnaturality_of σ g)).
      rewrite laxnaturality_natural.
      reflexivity.
    - intros X ; cbn in *.
      rewrite !vcomp_assoc.
      rewrite <- Fmor₂_id₂.
      rewrite <- (vcomp_right_identity (G ₂ id₂ (σ X))).
      rewrite !interchange.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
      rewrite Fcomp₂.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite <- Fmor₂_vcomp.
      rewrite (transformation_unit σ X).
      rewrite !vcomp_assoc.
      rewrite F_left_unit.
      rewrite !Fmor₂_vcomp.
      rewrite <- !vcomp_assoc.
      repeat f_ap.
      rewrite !vcomp_assoc.
      rewrite (F_right_unit_inv G).
      rewrite <- !vcomp_assoc.
      f_ap.
      rewrite !Fcomp₁_inv_naturality.
      f_ap.
      rewrite <- !interchange.
      rewrite !vcomp_right_identity.
      rewrite vcomp_assoc.
      unfold Fid_inv.
      rewrite vcomp_right_inverse, vcomp_right_identity.
      reflexivity.
    - intros X Y Z f g ; cbn in *.
      rewrite !vcomp_assoc.
      rewrite <- (vcomp_right_identity (id₂ (G ₁ σ X))).
      rewrite !interchange.
      rewrite !(ap (fun z => _ ∘ (_ ∘ z)) (vcomp_assoc _ _ _)^).
      rewrite <- Fmor₂_id₂.
      rewrite Fcomp₂.
      rewrite !vcomp_assoc.
      rewrite !(ap (fun z => _ ∘ z) (vcomp_assoc _ _ _)^).
      rewrite <- Fmor₂_vcomp.
      rewrite transformation_assoc.
      rewrite !vcomp_assoc.
      rewrite !Fmor₂_vcomp.
      rewrite <- !vcomp_assoc.
      rewrite Fcomp₁_inv_naturality.
      rewrite !vcomp_assoc.
      rewrite Fmor₂_id₂.
      rewrite <- (vcomp_right_identity (id₂ (G ₁ σ Z))).
      rewrite interchange.
      rewrite !vcomp_assoc.
      rewrite !vcomp_right_identity.
      f_ap.
      rewrite <- !vcomp_assoc.
      rewrite F_assoc_inv₁.
      rewrite !vcomp_assoc.
      repeat f_ap.
      rewrite <- (vcomp_right_identity (id₂ (G ₁ (F₁ ₁ f)))).
      rewrite !interchange.
      rewrite !vcomp_assoc, !vcomp_right_identity.
      f_ap.
      rewrite <- !vcomp_assoc.
      rewrite Fcomp₁_inv_naturality.
      rewrite !vcomp_assoc.
      rewrite <- (vcomp_right_identity (id₂ (G ₁ (F₁ ₁ f)))).
      rewrite !interchange.
      rewrite !vcomp_assoc, !Fmor₂_id₂.
      f_ap.
      pose (F_assoc G (F₂ ₁ g) (F₂ ₁ f) (σ X))^ as p.
      rewrite vcomp_assoc in p.
      rewrite p ; clear p.
      rewrite <- !vcomp_assoc.
      f_ap.
      rewrite !vcomp_assoc.
      rewrite <- (vcomp_right_identity (id₂ (G ₁ (F₂ ₁ g)))).
      rewrite interchange.
      rewrite vcomp_right_identity.
      rewrite <- !vcomp_assoc.
      rewrite <- F_assoc_inv₂.
      rewrite !vcomp_assoc.
      repeat f_ap.
      rewrite <- !vcomp_assoc.
      rewrite <- Fcomp₂.
      rewrite !vcomp_assoc.
      rewrite Fmor₂_id₂.
      repeat f_ap.
      rewrite <- interchange.
      rewrite vcomp_right_identity.
      reflexivity.
  Qed.

  Definition whisker_L
    : LaxTransformation (lax_comp G F₁) (lax_comp G F₂)
    := Build_LaxTransformation whisker_L_d whisker_L_d_is_lax.
End WhiskerL.

Global Instance whisker_L_is_pseudo
       `{Univalence}
       {C D E : BiCategory}
       {F₁ F₂ : LaxFunctor C D}
       (G : LaxFunctor D E)
       `{is_pseudo _ _ G}
       (η : LaxTransformation F₁ F₂)
       `{is_pseudo_transformation _ _ _ _ η}
  : is_pseudo_transformation (whisker_L G η).
Proof.
  intros X Y f ; cbn.
  apply _.
Defined.

Definition whisker_L_pseudo
           `{Univalence}
           {C D E : BiCategory}
           {F₁ F₂ : LaxFunctor C D}
           (G : PseudoFunctor D E)
           (σ : PseudoTransformation F₁ F₂)
  : PseudoTransformation (lax_comp G F₁) (lax_comp G F₂).
Proof.
  make_pseudo_transformation_lax.
  - exact (whisker_L G σ).
  - exact (whisker_L_is_pseudo G σ).
Defined.


Require Import Rupicola.Lib.Api.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Field.Interface.Compilation.
Require Import Crypto.Bedrock.Group.Point.
Require Import Crypto.Bedrock.Specs.Field.
Local Open Scope Z_scope.

Section __.
  Context {semantics : Semantics.parameters}
          {semantics_ok : Semantics.parameters_ok semantics}.
  Context {field_parameters : FieldParameters}
          {field_representaton : FieldRepresentation}
          {field_representation_ok : FieldRepresentation_ok}.
  Existing Instances spec_of_mul spec_of_square spec_of_add
           spec_of_sub spec_of_scmula24 spec_of_inv spec_of_felem_copy
           spec_of_felem_small_literal.
  Hint Resolve relax_bounds : compiler.

  Section Gallina.
    Local Open Scope F_scope.

    Definition ladderstep_gallina
               (X1: F M_pos) (P1 P2: point)  : (point * point) :=
      let '(X2, Z2) := P1 in
      let '(X3, Z3) := P2 in
      let/d A := X2+Z2 in
      let/d AA := A^2 in
      let/d B := X2-Z2 in
      let/d BB := B^2 in
      let/d E := AA-BB in
      let/d C := X3+Z3 in
      let/d D := X3-Z3 in
      let/d DA := D*A in
      let/d CB := C*B in
      let/d X5 := (DA+CB)^2 in
      let/d Z5 := X1*(DA-CB)^2 in
      let/d X4 := AA*BB in
      let/dZ4 := E*(AA + a24*E) in
      ((X4, Z4), (X5, Z5)).
  End Gallina.

  (* single predicate for all ladderstep end-state information *)
  (* N.B. it's important to leave the associativity of the predicate so that the
     emp is separated from the rest. This way, sepsimpl can easily pull it
     out. If sepsimpl is improved to handle very nested emps, this will not be
     necessary. *)
  Definition LadderStepResult
             (X1 X2 Z2 X3 Z3 : felem)
             (pX1 pX2 pZ2 pX3 pZ3 : Semantics.word)
             (pA pAA pB pBB pE pC pD pDA pCB : Semantics.word)
             (result : point * point)
    : list word -> Semantics.mem -> Prop :=
    fun _ =>
      (liftexists X4 Z4 X5 Z5 (* output values *)
                  A' AA' B' BB' E' C' D' DA' CB' (* new intermediates *)
       : felem,
         (emp (result = ((feval X4, feval Z4), (feval X5, feval Z5))
               /\ bounded_by tight_bounds X4
               /\ bounded_by tight_bounds Z4
               /\ bounded_by tight_bounds X5
               /\ bounded_by tight_bounds Z5)
          * (FElem pX1 X1 * FElem pX2 X4 * FElem pZ2 Z4
             * FElem pX3 X5 * FElem pZ3 Z5
             * FElem pA A' * FElem pAA AA'
             * FElem pB B' * FElem pBB BB'
             * FElem pE E' * FElem pC C' * FElem pD D'
             * FElem pDA DA' * FElem pCB CB'))%sep).

  Instance spec_of_ladderstep : spec_of "ladderstep" :=
    forall! (X1 X2 Z2 X3 Z3 : felem)
          (pX1 pX2 pZ2 pX3 pZ3
               pA pAA pB pBB pE pC pD pDA pCB : Semantics.word),
      (fun R m =>
        bounded_by tight_bounds X1
        /\ bounded_by tight_bounds X2
        /\ bounded_by tight_bounds Z2
        /\ bounded_by tight_bounds X3
        /\ bounded_by tight_bounds Z3
        /\ (FElem pX1 X1
            * FElem pX2 X2 * FElem pZ2 Z2
            * FElem pX3 X3 * FElem pZ3 Z3
            * Placeholder pA * Placeholder pAA
            * Placeholder pB * Placeholder pBB
            * Placeholder pE * Placeholder pC
            * Placeholder pD * Placeholder pDA
            * Placeholder pCB * R)%sep m)
        ===>
        "ladderstep" @ [pX1; pX2; pZ2; pX3; pZ3; pA; pAA; pB; pBB; pE; pC; pD; pDA; pCB]
        ===>
        (LadderStepResult
           X1 X2 Z2 X3 Z3 pX1 pX2 pZ2 pX3 pZ3
           pA pAA pB pBB pE pC pD pDA pCB
           (ladderstep_gallina
              (feval X1) (feval X2, feval Z2)
              (feval X3, feval Z3))).

    Lemma compile_ladderstep :
      forall (locals: Semantics.locals) (mem: Semantics.mem)
        (locals_ok : Semantics.locals -> Prop)
        tr retvars R R' functions T (pred: T -> _ -> _ -> Prop)
        x1 x2 z2 x3 z3
        X1 X1_ptr X1_var X2 X2_ptr X2_var Z2 Z2_ptr Z2_var
        X3 X3_ptr X3_var Z3 Z3_ptr Z3_var
        A_ptr A_var AA_ptr AA_var B_ptr B_var BB_ptr BB_var
        E_ptr E_var C_ptr C_var D_ptr D_var
        DA_ptr DA_var CB_ptr CB_var
        k k_impl,
        spec_of_ladderstep functions ->
        feval X1 = x1 ->
        feval X2 = x2 ->
        feval Z2 = z2 ->
        feval X3 = x3 ->
        feval Z3 = z3 ->
        bounded_by tight_bounds X1 ->
        bounded_by tight_bounds X2 ->
        bounded_by tight_bounds Z2 ->
        bounded_by tight_bounds X3 ->
        bounded_by tight_bounds Z3 ->
        (FElem X1_ptr X1
         * FElem X2_ptr X2 * FElem Z2_ptr Z2
         * FElem X3_ptr X3 * FElem Z3_ptr Z3
         * Placeholder A_ptr * Placeholder AA_ptr
         * Placeholder B_ptr * Placeholder BB_ptr
         * Placeholder E_ptr * Placeholder C_ptr
         * Placeholder D_ptr * Placeholder DA_ptr
         * Placeholder CB_ptr * R')%sep mem ->
        map.get locals X1_var = Some X1_ptr ->
        map.get locals X2_var = Some X2_ptr ->
        map.get locals Z2_var = Some Z2_ptr ->
        map.get locals X3_var = Some X3_ptr ->
        map.get locals Z3_var = Some Z3_ptr ->
        map.get locals A_var = Some A_ptr ->
        map.get locals AA_var = Some AA_ptr ->
        map.get locals B_var = Some B_ptr ->
        map.get locals BB_var = Some BB_ptr ->
        map.get locals E_var = Some E_ptr ->
        map.get locals C_var = Some C_ptr ->
        map.get locals D_var = Some D_ptr ->
        map.get locals DA_var = Some DA_ptr ->
        map.get locals CB_var = Some CB_ptr ->
        let v := ladderstep_gallina x1 (x2, z2) (x3, z3) in
        (let head := v in
         forall m,
           (LadderStepResult
             X1 X2 Z2 X3 Z3 X1_ptr X2_ptr Z2_ptr X3_ptr
             Z3_ptr A_ptr AA_ptr B_ptr BB_ptr E_ptr C_ptr D_ptr DA_ptr
             CB_ptr head [] * R')%sep m ->
           (find k_impl
            implementing (pred (k head))
            and-returning retvars
            and-locals-post locals_ok
            with-locals locals
            and-memory m and-trace tr and-rest R
            and-functions functions)) ->
        (let head := v in
         find (cmd.seq
                 (cmd.call [] "ladderstep"
                           [ expr.var X1_var; expr.var X2_var;
                               expr.var Z2_var; expr.var X3_var;
                                 expr.var Z3_var; expr.var A_var;
                                   expr.var AA_var; expr.var B_var;
                                     expr.var BB_var; expr.var E_var;
                                       expr.var C_var; expr.var D_var;
                                         expr.var DA_var; expr.var CB_var ])

                 k_impl)
         implementing (pred (dlet head k))
         and-returning retvars
         and-locals-post locals_ok
         with-locals locals
         and-memory mem and-trace tr and-rest R
         and-functions functions).
    Proof.
      repeat straightline'.
      handle_call; [ solve [eauto] .. | sepsimpl ].
      repeat straightline'. subst. eauto.
    Qed.

  Ltac ladderstep_compile_custom :=
    repeat compile_compose_step;
    field_compile_step; [ repeat compile_step .. | ];
    (* if the output we selected was one of the inputs, need to write the
       Placeholder back into a FElem for the arguments precondition *)
    lazymatch goal with
    | |- sep _ _ _ =>
      seprewrite FElem_from_bytes;
      solve [repeat compile_step]
    | _ => idtac
    end;
    [ solve [repeat compile_step] .. | intros ].

  Ltac compile_custom ::= ladderstep_compile_custom.

  Derive ladderstep_body SuchThat
         (let args := ["X1"; "X2"; "Z2"; "X3"; "Z3";
                         "A"; "AA"; "B"; "BB"; "E"; "C";
                           "D"; "DA"; "CB"] in
          let ladderstep := ("ladderstep", (args, [], ladderstep_body)) in
          program_logic_goal_for
            ladderstep
            (ltac:(let x := program_logic_goal_for_function
                              ladderstep [mul;add;sub;square;scmula24] in
                   exact x)))
    As ladderstep_body_correct.
  Proof.
    cbv [program_logic_goal_for spec_of_ladderstep].
    setup.
    repeat safe_compile_step.

    (* by now, we're out of Placeholders; need to decide (manually for now)
       where output gets stored *)
    free pX3; repeat safe_compile_step.
    free pZ3; repeat safe_compile_step.
    free pX2; repeat safe_compile_step.
    free pZ2; repeat safe_compile_step.

    (* sanity-check that compilation is done *)
    lazymatch goal with
    | |- context [dlet.dlet] => fail
    | _ => idtac
    end.

    (* done! now just prove postcondition *)
    compile_done. cbv [LadderStepResult].
    repeat lazymatch goal with
           | |- Lift1Prop.ex1 _ _ => eexists
           | |- sep _ _ _ =>
             first [ progress sepsimpl
                   | ecancel_assumption ]
          end.
    all:lazymatch goal with
        | |- bounded_by _ _ => solve [auto with compiler]
        | _ => idtac
        end.
    congruence.
  Qed.
End __.

Local Coercion expr.var : string >-> Syntax.expr.
Local Unset Printing Coercions.
Redirect "Crypto.Bedrock.Group.ScalarMult.LadderStep.ladderstep_body" Print ladderstep_body.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.DownwardsSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section Sound_Downwards.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        (M: Kmodel)
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {dSA: DownwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {kminSM: KripkeMinimumSemantics L MD M SM}
        {kpSM: KripkePropositionalSemantics L MD M SM}
        {dsepconSM: DownwardsSemantics.SepconSemantics L MD M SM}
        {dwandSM: DownwardsSemantics.WandSemantics L MD M SM}.

Lemma sound_sepcon_comm:
  forall x y: expr,
    forall m,
      KRIPKE: M, m |= x * y --> y * x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0 |- *; intros.
  destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  exists m0, m2, m1.
  split; [| split]; auto.
  apply join_comm; auto.
Qed.

Lemma sound_sepcon_assoc:
  forall x y z: expr,
    forall m,
      KRIPKE: M, m |= x * (y * z) <--> (x * y) * z.
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp.
  split; intros.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon in H0.
    destruct H0 as [n' [mx' [myz' [? [? [? ?]]]]]].
    rewrite sat_sepcon in H3.
    destruct H3 as [myz'' [my'' [mz'' [? [? [? ?]]]]]].
    apply join_comm in H1.
    apply join_comm in H4.
    assert (mx' <= mx') by reflexivity.
    destruct (join_Korder_down _ _ _ _ _ H1 H3 H7) as [n'' [? ?]].
    destruct (join_assoc mz'' my'' mx' myz'' n'' H4 H8) as [mxy'' [? ?]].
    apply join_comm in H10.
    apply join_comm in H11.
    rewrite sat_sepcon.
    exists n'', mxy'', mz''.
    split; [| split; [| split]]; auto.
    - etransitivity; eauto.
    - rewrite sat_sepcon.
      exists mxy'', mx', my''.
      split; [| split; [| split]]; auto.
      reflexivity.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon in H0.
    destruct H0 as [n' [mxy' [mz' [? [? [? ?]]]]]].
    rewrite sat_sepcon in H2.
    destruct H2 as [mxy'' [mx'' [my'' [? [? [? ?]]]]]].
    assert (mz' <= mz') by reflexivity.
    destruct (join_Korder_down _ _ _ _ _ H1 H2 H7) as [n'' [? ?]].
    destruct (join_assoc mx'' my'' mz' mxy'' n'' H4 H8) as [myz'' [? ?]].
    rewrite sat_sepcon.
    exists n'', mx'', myz''.
    split; [| split; [| split]]; auto.
    - etransitivity; eauto.
    - rewrite sat_sepcon.
      exists myz'', my'', mz'.
      split; [| split; [| split]]; auto.
      reflexivity.
Qed.

Lemma sound_wand_sepcon_adjoint:
  forall x y z: expr,
   (forall m, KRIPKE: M, m |= x * y --> z) <-> (forall m, KRIPKE: M, m |= x --> (y -* z)).
Proof.
  intros.
  split; intro.
  + assert (ASSU: forall m0 m1 m2 m, m0 <= m -> join m1 m2 m0 -> KRIPKE: M, m1 |= x -> KRIPKE: M, m2 |= y -> KRIPKE: M, m |= z).
    {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      apply (H m); [reflexivity |].
      rewrite sat_sepcon.
      exists m0, m1, m2; auto.
    }
    clear H.
    intros.
    rewrite sat_impp; intros.
    rewrite sat_wand; intros.
    apply (ASSU m2 n m1 m2); auto.
    reflexivity.
  + assert (ASSU: forall m1 m2 m, join m m1 m2 -> KRIPKE: M, m |= x -> KRIPKE: M, m1 |= y -> KRIPKE: M, m2 |= z).
    {
      intros.
      specialize (H m).
      rewrite sat_impp in H.
      revert m1 m2 H0 H2.
      rewrite <- sat_wand.
      apply (H m); [reflexivity | auto].
    }
    intros.
    rewrite sat_impp; intros.
    rewrite sat_sepcon in H1.
    destruct H1 as [m0 [m1 [m2 [? [? [? ?]]]]]].
    pose proof (ASSU m2 m0 m1 H2 H3 H4).
    eapply sat_mono; eauto.
Qed.

Lemma sound_sepcon_mono:
  forall x1 x2 y1 y2: expr,
   (forall m, KRIPKE: M, m |= x1 --> x2) ->
   (forall m, KRIPKE: M, m |= y1 --> y2) ->
   (forall m, KRIPKE: M, m |= x1 * y1 --> x2 * y2).
Proof.
  intros.
  assert (ASSUx: forall m, KRIPKE: M, m |= x1 -> KRIPKE: M, m |= x2).
  {
    intros.
    specialize (H m0).
    rewrite sat_impp in H.
    apply (H m0); [reflexivity | auto].
  }
  assert (ASSUy: forall m, KRIPKE: M, m |= y1 -> KRIPKE: M, m |= y2).
  {
    intros.
    specialize (H0 m0).
    rewrite sat_impp in H0.
    apply (H0 m0); [reflexivity | auto].
  }
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H2 |- *.
  destruct H2 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  exists m0, m1, m2; auto.
Qed.

Lemma sound_sepcon_elim1 {incrSA: IncreasingSeparationAlgebra (Kworlds M)}:
  forall x y: expr,
    forall m, KRIPKE: M, m |= x * y --> x.
Proof.
  intros.
  rewrite sat_impp; intros.
  rewrite sat_sepcon in H0.
  destruct H0 as [m0 [m1 [m2 [? [? [? ?]]]]]].
  apply join_comm in H1.
  apply all_increasing in H1.
  eapply sat_mono; eauto.
  eapply sat_mono; eauto.
Qed.

Context {empL: EmpLanguage L}
        {dempSM: DownwardsSemantics.EmpSemantics L MD M SM}.

Lemma sound_sepcon_emp {USA: UnitalSeparationAlgebra (Kworlds M)}:
  forall x: expr,
    forall m, KRIPKE: M, m |= x * emp <--> x.
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp.
  split.
  + rewrite sat_impp; intros.
    clear m H.
    rewrite sat_sepcon in H0.
    destruct H0 as [m'' [m' [u [? [? [? ?]]]]]].
    rewrite sat_emp in H2.
    apply join_comm in H0.
    unfold increasing in H2.
    apply H2 in H0.
    eapply sat_mono; eauto.
    eapply sat_mono; eauto.
  + rewrite sat_impp; intros.
    rewrite sat_sepcon.
    destruct (incr_exists n) as [u [? ?]].
    destruct H1 as [n' [H1 H1']].
    exists n, n', u.
    split; [| split; [| split]]; auto.
    - reflexivity.
    - apply join_comm; auto.
    - eapply sat_mono; eauto.
    - rewrite sat_emp.
      auto.
Qed.

End Sound_Downwards.