(* Julien Narboux *)
(* Formalization of *)
(* Tarski's axiomatic *)

Require Export  general_tactics.

(** We use the axioms used in the book of Schwabäuser, Szmielew and Tarski. *)

(** We assume that we have a set of points. This axiomatic is based only on points, lines are implicit. *)

Parameter Point : Set.

(* Here we use classical logic, for a intuitionnist approach
use von Plato axiomatic for instance.
In this development, the classic axiom is mainly applied to formulas of the form :
- Col A B C,
- A=B
*)

Require Export Classical.

(** Tarski's axiomatic is based on two predicates over points,
one ternary and one quaternary. *)

(** Cong A B C D informally means that the distance AB
is equal to the distance CD. *)

Parameter Cong : Point -> Point -> Point -> Point -> Prop.

(** Bet A B C, informally means that :
A, B and C are on the same line
B is between A and C.
Note that they are not necessarily distinct.
This is the difference between
the Between predicate of Tarski and the BetweenH prdicate of Hilbert
*)

Parameter Bet : Point -> Point -> Point -> Prop.

Definition Col (A B C : Point) : Prop :=
  Bet A B C \/ Bet B C A \/ Bet C A B.

Ltac cases_col A B C := elim (classic (Col A B C));intros.

(** %\textbf{% Identity axiom for betweenness. %}% *)

Axiom between_identity : forall A B, Bet A B A -> A=B.

(** %\textbf{% Reflexivity axiom for equidistance.%}% *)

Axiom cong_pseudo_reflexivity : forall A B : Point, Cong A B B A.

(** %\textbf{% Identity axiom for equidistance.%}% *)

Axiom cong_identity : forall A B C : Point, Cong A B C C -> A = B.

(** %\textbf{% Transitivity axiom for equidistance.%}% *)

Axiom cong_inner_transitivity : forall A B C D E F : Point,
   Cong A B C D -> Cong A B E F -> Cong C D E F.

(** %\textbf{% Pasch Axiom (Inner form).%}% *)

Axiom inner_pasch : forall A B C P Q : Point,
      Bet A P C -> Bet B Q C ->
      exists x, Bet P x B /\ Bet Q x A.

(** %\textbf{% Euclid Axiom.%}% *)

Axiom euclid : forall A B C D T : Point,
    Bet A D T -> Bet B D C -> A<>D ->
    exists x, exists y,
    Bet A B x /\ Bet A C y /\ Bet x T y.

(** %\textbf{% Five segments axiom.%}% *)

Axiom five_segments : forall A A' B B' C C' D D' : Point,
    Cong A B A' B' ->
    Cong B C B' C' ->
    Cong A D A' D' ->
    Cong B D B' D' ->
    Bet A B C -> Bet A' B' C' -> A <> B -> Cong C D C' D'.

(** %\textbf{% Axiom of segment construction.%}% *)

Axiom segment_construction : forall A B C D : Point,
    exists E : Point, Bet A B E /\ Cong B E C D.

(** %\textbf{% Lower dimension axiom (2).%}% *)

Axiom lower_dim :
    exists A, exists B, exists C, ~ Col A B C.

(** %\textbf{% Upper dimension axiom  (2).%}% *)

Axiom upper_dim : forall A B C P Q : Point,
    P <> Q -> Cong A P A Q -> Cong B P B Q -> Cong C P C Q ->
    Col A B C.

(** %\textbf{% Continuity axioms.%}% *)

Axiom continuity :
    forall X Y : Point -> Prop,
    (exists A : Point, (forall x y : Point, X x -> Y y -> Bet A x y)) ->
    exists B : Point, (forall x y : Point, X x -> Y y -> Bet x B y).

Hint Resolve segment_construction five_segments inner_pasch euclid : Tarski.
Hint Resolve cong_pseudo_reflexivity cong_identity between_identity : Tarski.
Hint Resolve cong_inner_transitivity  : Tarski.

Ltac eTarski := eauto with Tarski.
Ltac Tarski := auto with Tarski.

(** We use classical logic, to emphasize the fact that it is mainly for the decidability of point equality we use the
following lemma *)

Lemma eq_dec_points : forall A B:Point, A=B \/ ~ A=B.
Proof.
intros.
apply classic.
Qed.

Ltac cases_equality A B := elim (eq_dec_points A B);intros.


Inductive Id {A:Type} : A->A->Type := id_refl : forall (t:A),Id t t.

Notation "x == y" := (Id x y) (at level 70).

Definition concat {A} {x y z:A} : (x==y) -> (y==z) -> (x==z).
  intros p q.
  induction p.
  exact q.
Defined.

Definition inverse {A} {x y:A} : (x==y) -> (y==x).
  intros p.
  induction p.
  apply id_refl.
Defined.

Notation "p @ q" := (concat p q) (at level 60).
Notation "! p" := (inverse p) (at level 50).

Definition id_left_unit {A} {x y:A} (p:x==y) : (id_refl x) @ p == p.
  induction p.
  apply id_refl.
Defined.

Definition id_right_unit {A} {x y:A} (p:x==y) : p @ (id_refl y) == p.
  induction p.
  apply id_refl.
Defined.

Definition id_right_inverse {A} {x y:A} (p:x==y) : (p @ !p) == (id_refl x).
  induction p.
  apply id_refl.
Defined.

Definition id_left_inverse {A} {x y:A} (p:x==y) : (!p @ p) == (id_refl y).
  induction p.
  apply id_refl.
Defined.

Definition assoc {A} {x y z w:A} (p:x==y) (q:y==z) (r:z==w) : (p @ q) @ r == p @ (q @ r).
  induction p;induction q;induction r.
  apply id_refl.
Defined.

(*========= basic naturality laws ========*)
Definition concat2 {A} {x y z:A} {p q:x==y} {r s:y==z} : p==q -> r==s -> p @ r == q @ s.
  intros f g.
  induction f ;induction g.
  apply id_refl.
Defined.

Notation "p [@] q" := (concat2 p q) (at level 61).

Definition assoc_is_left_monoidal {A} {x y z:A} (q:x==y) (r:y==z) : (assoc (id_refl _) q r)==(id_refl (q@r)).
  induction q;induction r;apply id_refl.
Defined.

Definition assoc_is_center_monoidal {A} {x y z:A} (p:x==y) (r:y==z) :
   (assoc p (id_refl _) r)==(id_right_unit p)[@](id_refl r).
Proof.
  induction p;induction r;apply id_refl.
Defined.

Definition assoc_is_right_monoidal {A} {x y z:A} (p:x==y) (q:y==z) :
  (assoc p q (id_refl _))==(id_right_unit (p@q))@(id_refl p[@]!id_right_unit q).
Proof.
  induction p;induction q;apply id_refl.
Defined.

Definition id_right_unit_is_natural {A} {x y:A} {p q:x==y} (f:p==q) :
   (f [@] (id_refl _))@(id_right_unit q)==(id_right_unit p)@f.
Proof.
  induction f;induction t;apply id_refl.
Defined.

Definition assoc_is_natural {A} {x y z w:A} {p p':x==y} {q q':y==z} {r r':z==w} (f:p==p') (g:q==q') (h:r==r'):
  (f[@]g[@]h)@(assoc p' q' r') == (assoc p q r)@(f[@](g[@]h)).
Proof.
  induction f;induction g;induction h.
  induction t;induction t0;induction t1.
  apply id_refl.
Defined.

(*========= bicategory coherence laws ============*)
(* K4 coherence is pentagon equation *)

Definition K4 {A} {x y z w u:A} (a:x==y) (b:y==z) (c:z==w) (d:w==u) :
   ((assoc a b c) [@] (id_refl d)) @ (assoc a (b @ c) d) @ ((id_refl a) [@] (assoc b c d)) ==
      (assoc (a @ b) c d) @ (assoc a b (c @ d)).
  induction a;induction b;induction c;induction d.
  apply id_refl.
Defined.

Definition u3 {A} {x y z:A} (a:x==y) (b:y==z) :
   (concat2 (id_right_unit a) (id_refl b))==
      (assoc a (id_refl y) b) @ (concat2(id_refl a) (id_left_unit b)).
  induction a;induction b.
  apply id_refl.
Defined.

(* inverseに対するcoherence? *)
Definition left_rigid1 {A} {x y:A} (a:x==y) :
   !(id_left_unit a) @ (concat2 (!(id_right_inverse a)) (id_refl a)) @
        (assoc a (!a) a) @ (concat2 (id_refl a) (id_left_inverse a)) @ (id_right_unit a) ==
           id_refl a.
  induction a.
  apply id_refl.
Defined.

Definition left_rigid2 {A} {x y:A} (a:x==y) :
  !(id_right_unit (!a)) @ (concat2 (id_refl (!a)) (!(id_right_inverse a))) @
      !(assoc (!a) a (!a)) @ (concat2 (id_left_inverse a) (id_refl (!a))) @ (id_left_unit (!a)) ==
         id_refl (!a).
  induction a.
  apply id_refl.
Defined.

(*=========== K5 coherence ============*)
Definition concat3 {A} {x y z:A} {p q:x==y} {r s:y==z} {X Y:p==q} {Z W:r==s} : X==Y -> Z==W -> X [@] Z==Y [@] W.
  intros f g.
  induction f ;induction g.
  apply id_refl.
Defined.

Notation "p [[@]] q" := (concat3 p q) (at level 62).

(*
distl and distr are special cases of "(a@b)[@](c@d) == (a[@]b)@(c[@]d)"
*)
Definition distr {A} {x y z:A} {p q r:x==y} (s:y==z) (X:p==q) (Y:q==r) :
  (X @ Y) [@] (id_refl s) == (X[@](id_refl s)) @ (Y[@](id_refl s)).
Proof.
  induction X;induction Y.
  apply id_refl.
Defined.

Definition distl {A} {x y z:A} {p q r:y==z} (s:x==y) (X:p==q) (Y:q==r) :
   (id_refl s) [@] (X @ Y) == ((id_refl s) [@] X) @ ((id_refl s) [@] Y).
Proof.
  induction X;induction Y.
  apply id_refl.
Defined.

Definition id_save {A} {x y z:A} (p:x==y) (q:y==z) : (id_refl p) [@] (id_refl q) == id_refl (p@q).
  induction p;induction q;apply id_refl.
Defined.

Definition K5_LHS {A} {x y z w u v:A} (a:x==y) (b:y==z) (c:z==w) (d:w==u) (e:u==v) :=
         (
            ((assoc _ _ _) [@] (id_refl _)) @
            (assoc _ (_@_) _)
         ) @
         (
           (
             (
               (!(distr e ((assoc a b c)[@](id_refl d)) (assoc a (b@c) d))) [@]
               (id_refl ( (id_refl a) [@] (assoc b c d) [@] (id_refl e) ))
             ) @
             (
               (!(distr e _ _))
             )
           ) [@]
           (
              (id_refl _)
           )
        ) @
        (
          (
            ( (K4 a b c d) [[@]] (id_refl (id_refl e)) ) @
            ( distr e (assoc (a @ b) c d) (assoc a b (c @ d)) )
          ) [@]
          (id_refl
            ( (assoc a (b@(c@d)) e) @
              ((id_refl a) [@] (assoc b (c@d) e)) @
              ((id_refl a) [@] ((id_refl b) [@] (assoc c d e)))
            )
          )
        ) @
        (
          !(assoc (_@_) (_@_) _) @
          ((assoc _ _ (_@_)) [@] (id_refl _)) @
          (((id_refl _) [@] !(assoc _ _ _))[@](id_refl _))
        ) @
        (
           (id_refl ( (assoc (a@b) c d) [@] (id_refl e) )) [@]
           (K4 a b (c@d) e) [@]
           (id_refl (( (id_refl a) [@] ((id_refl b) [@] (assoc c d e)) )))
        ) @
        (
           (!(assoc _ _ _) [@] (id_refl _)) @ (assoc _ _ _)
        ) @
        (
           (id_refl ( (assoc (a@b) c d) [@] (id_refl e) )) [@]
           (id_refl (assoc (a@b) (c@d) e)) [@]
           (
             (!assoc_is_natural (id_refl a) (id_refl b) (assoc c d e)) @
             ( ((id_save a b) [[@]] (id_refl (assoc c d e))) [@] (id_refl _) )
           )
        ) @
        (
           !(assoc _ _ _)
        ) @
        (
           (K4 (a@b) c d e) [@] (id_refl (assoc a b _))
        ).

Definition K5_RHS {A} {x y z w u v:A} (a:x==y) (b:y==z) (c:z==w) (d:w==u) (e:u==v) :=
        (
           (assoc (_@_) _ _) [@] (id_refl _) [@] (id_refl _)
        ) @
        (
           (id_refl ((assoc a b c) [@] (id_refl d) [@] (id_refl e))) [@]
           (id_refl ((assoc a (b@c) d) [@] (id_refl e))) [@]
           (assoc_is_natural (id_refl a) (assoc b c d) (id_refl e)) [@]
           (id_refl ((id_refl a) [@] (assoc b (c@d) e))) [@]
           (id_refl ((id_refl a) [@] ((id_refl b) [@] (assoc c d e))))
        ) @
        (
           ( (!(assoc (_@_) _ _)) [@] (id_refl _) [@] (id_refl _) ) @
           ( assoc (_@_@_@_) _ _ ) @
           ( assoc (_@_@_) _ (_@_) ) @
           ( (id_refl _) [@] ((id_refl _) [@] (!(distl a _ _))) ) @
           ( (id_refl _) [@] (!(distl a _ _)) ) @
           ( (id_refl _) [@] ((id_refl (id_refl a)) [[@]] !(assoc _ _ _)) )
        ) @
        (
           (id_refl ((assoc a b c) [@] (id_refl d) [@] (id_refl e))) [@]
           (id_refl ((assoc a (b@c) d) [@] (id_refl e))) [@]
           (id_refl (assoc a _ e)) [@]
           ( (id_refl (id_refl a)) [[@]] (K4 b c d e) )
        ) @
        (
           ((id_refl _) [@] (distl a _ _)) @
           !(assoc _ _ _) @
           ( (assoc _ _ _) [@] (id_refl _) [@] (id_refl _) ) @
           ( (assoc _ _ _) [@] (id_refl _) )
        ) @
        (
           (id_refl ((assoc a b c[@]id_refl d)[@]id_refl e) ) [@]
           (K4 a (b@c) d e) [@]
           (id_refl ((id_refl a) [@] (assoc _ _ _)))
        ) @
        (
          ( !(assoc _ _ _) [@] (id_refl _) )
        ) @
        (
          ((assoc_is_natural (assoc a b c) (id_refl d) (id_refl e))) [@]
          (id_refl (assoc _ _ _)) [@]
          (id_refl ((id_refl a) [@] (assoc _ _ _)))
        ) @
        (
          ( ( (id_refl _) [@]
              ((id_refl (assoc a b c))[[@]](id_save d e)) ) [@]
            (id_refl _) ) [@]
          (id_refl _)
        ) @
        (
           (assoc (_ @ _) _ _) @
           (assoc _ _ (_ @ _)) @
           ((id_refl _) [@] !(assoc _ _ _))
        ) @
        (
           (id_refl _) [@] (K4 a b c (d@e))
        ) @
        (
           !(assoc _ _ _)
        ).

Definition K5 {A} {x y z w u v:A} (a:x==y) (b:y==z) (c:z==w) (d:w==u) (e:u==v) :
    K5_LHS a b c d e == K5_RHS a b c d e.
Proof.
   induction a;induction b;induction c;induction d;induction e.
   apply id_refl.
Defined.

(*===================== higher commutativity laws =====================*)
Definition interchange {A} {x y z:A} {p q r:x==y} {s t u:y==z} (a:p==q) (b:q==r) (c:s==t) (d:t==u) :
  (a @ b) [@] (c @ d) == (a [@] c) @ (b [@] d).
Proof.
   induction a;induction b;induction c;induction d.
   apply id_refl.
Defined.

Definition concat2_is_left_unital {A} {x y:A} {p q:x==y} (s:p==q) :
  (id_refl (id_refl x)) [@] s == (id_left_unit p) @ s @ !(id_left_unit q).
Proof.
  induction s.
  induction t.
  apply id_refl.
Defined.

Definition concat2_is_right_unital {A} {x y:A} {p q:x==y} (s:p==q) :
  s [@] (id_refl (id_refl y)) == (id_right_unit p) @ s @ !(id_right_unit q).
Proof.
  induction s.
  induction t.
  apply id_refl.
Defined.

Definition concat2_is_left_unital_pt {A} {x:A} (s:(id_refl x)==(id_refl x)) :
   (id_refl (id_refl x)) [@] s == s.
Proof.
   exact( (concat2_is_left_unital s) @ (id_right_unit (_@s)) ).
Defined.

Definition concat2_is_right_unital_pt {A} {x:A} (s:(id_refl x)==(id_refl x)) :
   s [@] (id_refl (id_refl x)) == s.
Proof.
   exact( (concat2_is_right_unital s) @ (id_right_unit s) ).
Defined.

(*
Eckmann-Hilton argument:
a @ b == (e [@] a) @ (b [@] e) == (e @ b) [@] (a @ e) == b [@] a ==
(b @ e) [@] (e @ a) == (b [@] e) @ (e [@] a) == b@a
*)

Definition comm {A} {x:A} (a b:(id_refl x)==(id_refl x)): a @ b == b @ a.
  set (e:=id_refl (id_refl x)).
  assert(p1 := ((concat2_is_left_unital_pt a) [@] (concat2_is_right_unital_pt b))).
  assert(p2 := interchange e b a e).
  assert(p3 := (!id_left_unit b) [[@]] (!id_right_unit a)).
  assert(p4 := (!id_right_unit b) [[@]] (!id_left_unit a)).
  assert(p5 := interchange b e e a).
  assert(p6 := ((concat2_is_right_unital_pt b) [@] (concat2_is_left_unital_pt a))).
  exact ( ((!p1) @ (!(p3 @ p2))) @ ((p4 @ p5) @ p6) ).
Defined.

Definition comm_is_dinatural {A} {x:A} {a b a' b':(id_refl x)==(id_refl x)} (f:a==a') (g:b==b') :
   (f [@] g)@(comm a' b')==(comm a b)@(g [@] f).
Proof.
   induction f;induction g.
   exact (!id_right_unit _).
Defined.

(* ===== prove hexagon and Yang-Baxter equation ======*)
(*
Reference:
A.Joyal and R.Street,
Braided tensor categories, Advances in Math. 102 (1993) 20-78
http://maths.mq.edu.au/~street/JS1.pdf
*)

(* analogous to Hom(X,Y) -> Hom(Y^{*},X^{*}) *)
Definition dualize {A} {x y:A} {p q:x==y} : (p==q) -> (!q==!p).
Proof.
  intro f.
  exact(
    (!id_right_unit (!q)) @
    ((id_refl _) [@] (!id_right_inverse p)) @
    ((id_refl _) [@] (f [@] id_refl _)) @
    (!assoc (!q) (q) (!p)) @
    ((id_left_inverse _) [@] (id_refl _)) @
    (id_left_unit _)
  ).
Defined.

Definition inv_dist {A} {x y z:A} (p:x==y) (q:y==z):!(p @ q)==!q @ !p.
  induction p;induction q;apply id_refl.
Defined.

Definition dualize_dist {A} {x y:A} {p q r:x==y} (s:p==q) (t:q==r) :
   dualize (s @ t) == (dualize t) @ (dualize s).
Proof.
   induction s;induction t.
   induction t.
   apply id_refl.
Defined.

Definition dualize_id_left_unit {A} {x y:A} (p:x==y) :
   (dualize (id_left_unit p)) == (!id_right_unit (!p))@(!inv_dist (!id_refl x) p).
Proof.
   induction p;apply id_refl.
Defined.

Definition inv_sq {A} {x y:A} (p:x==y) : !(!p)==p.
   induction p;apply id_refl.
Defined.

Definition dualize_sq {A} {x y:A} {p q:x==y} (s:p==q) :
  (dualize (dualize s))==(inv_sq p)@s@(!inv_sq q).
Proof.
  induction s;induction t;apply id_refl.
Defined.

Definition dualize_commute_inv {A} {x y:A} {p q:x==y} (s:p==q):
   dualize (!s)==!(dualize s).
Proof.
 induction s;induction t;apply id_refl.
Defined.

Definition inv3 {A} {x y:A} {p q:x==y} {s t:p==q} : s==t -> dualize t==dualize s.
   intro f;induction f;apply id_refl.
Defined.

Definition MF3 {A} {x y z:A} {p1 p2 p3 p4:x==y} {q1 q2 q3 q4:y==z}
   (a:p1==p2) (b:p2==p3) (c:p3==p4) (a':q1==q2) (b':q2==q3) (c':q3==q4):
      (interchange a (b@c) a' (b'@c'))@
      ((id_refl (a[@]a')) [@] (interchange b c b' c'))@
      (!assoc (a[@]a') (b[@]b') (c[@]c'))
      ==
      (!((assoc a b c) [[@]] (assoc a' b' c')))@
      (interchange (a@b) c (a'@b') c')@
      ((interchange a b a' b') [@] (id_refl (c[@]c'))).
Proof.
  induction a;induction b;induction c;induction a';induction b';induction c'.
  apply id_refl.
Defined.

Definition id_left_unit_is_identity {A} {x y:A} (p:x==y):id_left_unit p==id_refl p.
   induction p;apply id_refl.
Defined.

Definition PI_partL {A} {x y:A} {p q r:x==y} (a:p==q) (b:q==r) :
   (id_left_unit p @ a @ !id_left_unit q) @ (id_left_unit q @ b @ !id_left_unit r)==
     (id_left_unit p)@(a@b)@(!id_left_unit r).
Proof.
exact(
  (
     (
        ((id_refl _) [@] (!dualize (id_left_unit_is_identity q))) @
        (id_right_unit (_@a)) @
        ((id_left_unit_is_identity p) [@] (id_refl _))
     ) [@]
     (
        ((id_refl _) [@] (!dualize (id_left_unit_is_identity r))) @
        (id_right_unit (_@b)) @
        ((id_left_unit_is_identity q) [@] (id_refl _))
     )
  ) @
  !(
     ((id_refl _) [@] (!dualize (id_left_unit_is_identity r))) @
     (id_right_unit (_@(a@b))) @
     ((id_left_unit_is_identity p) [@] (id_refl _))
  )
).
Defined.

Definition PIL_proto {A} {x y:A} {p q r:x==y} (a:p==q) (b:q==r) :
  concat2_is_left_unital (a@b) ==
     (interchange _ _ a b) @
     (concat2_is_left_unital a [@] concat2_is_left_unital b) @
     (PI_partL a b).
Proof.
   induction a;induction b.
   induction t.
   apply id_refl.
Defined.

Definition PIL {A} {x:A} (a b:(id_refl x)==(id_refl x)) :
  concat2_is_left_unital_pt (a@b) ==
    ( interchange (id_refl (id_refl x)) (id_refl (id_refl x)) a b ) @
    ( concat2_is_left_unital_pt a [@] concat2_is_left_unital_pt b ).
Proof.
  set(Hab := id_right_unit (id_left_unit (id_refl x) @ (a @ b))).
  set(Ha := id_right_unit (id_left_unit (id_refl x) @ a)).
  set(Hb := id_right_unit (id_left_unit (id_refl x) @ b)).
  set(c := id_right_unit (a @ b) @ id_refl (a @ b)).
  exact (
    ((PIL_proto a b) [@] (id_refl Hab)) @
    (assoc _ (PI_partL a b) Hab) @
    ((id_refl _) [@] (assoc _ (!c) Hab)) @
    ((id_refl _) [@] ((id_refl _) [@] ((inv_dist _ _)[@](id_refl Hab)))) @
    ((id_refl _) [@] ((id_refl _) [@] (id_left_inverse _))) @
    ((id_refl _) [@] (id_right_unit _)) @
    (assoc _ _ _) @
    ((id_refl _) [@] (((id_refl _) [[@]] (id_refl _)) [@] ((id_right_unit Ha) [[@]] (id_right_unit Hb)))) @
    ((id_refl _) [@] (!interchange _ Ha _ Hb))
  ).
Defined.

Definition inv_dist2 {A} {x y z:A} {p q:x==y} {r s:y==z} (X:p==q) (Y:r==s) : !(X[@]Y)==(!X[@]!Y).
  induction X;induction Y;apply id_refl.
Defined.

Definition PI_partR {A} {x y:A} {p q r:x==y} (a:p==q) (b:q==r) :
   (id_right_unit p @ a @ !id_right_unit q) @ (id_right_unit q @ b @ !id_right_unit r)==
     (id_right_unit p)@(a@b)@(!id_right_unit r).
Proof.
  set(H:=
    (assoc a (!id_right_unit q) (id_right_unit q @ b)) @
    ((id_refl a) [@] (!assoc (!id_right_unit q) _ b)) @
    ((id_refl a) [@] ((id_left_inverse _) [@] (id_refl b))) @
    ((id_refl a) [@] (id_left_unit b))
  ).
  exact(
    ((assoc (id_right_unit p) a (!id_right_unit q)) [@] (id_refl (id_right_unit q @ b @ !id_right_unit r))) @
    (assoc (id_right_unit p) _ _)@
    ((id_refl (id_right_unit p)) [@] (!assoc _ _ _))@
    (!assoc (id_right_unit p) _ (!id_right_unit r)) @
    ((id_refl (id_right_unit p)) [@] H [@] (id_refl _))
  ).
Defined.

Definition PIR_proto {A} {x y:A} {p q r:x==y} (a:p==q) (b:q==r) :
  concat2_is_right_unital (a@b) ==
     (interchange a b _ _) @
     (concat2_is_right_unital a [@] concat2_is_right_unital b) @
     (PI_partR a b).
Proof.
   induction a;induction b.
   induction t.
   apply id_refl.
Defined.

Definition PIR {A} {x:A} (a b:id_refl x==id_refl x) :
  concat2_is_right_unital_pt (a@b) ==
    ( interchange a b (id_refl (id_refl x)) (id_refl (id_refl x)) ) @
    ( concat2_is_right_unital_pt a [@] concat2_is_right_unital_pt b ).
Proof.
  set(p:=id_refl x).
  set(q:=id_refl x).
  set(r:=id_refl x).
  set(va:=a @ (!id_right_unit q)).
  set(vb:=(id_right_unit q) @ b).

  set(redH :=
    (
      (
        (
          (assoc_is_center_monoidal a (id_right_unit q @ b)) [@]
          ((id_refl (id_refl a)) [[@]] (!dualize (assoc_is_center_monoidal (!id_right_unit q) b))) [@]
          (id_refl ((id_refl a) [@] ((id_left_inverse _) [@] (id_refl b))))
        )@(id_right_unit _)@(id_right_unit _)
      )[@]
      (id_refl ((id_refl a) [@] (id_left_unit b)))
    )@(!interchange _ _ _ _)@((id_right_unit _)[[@]](id_left_unit _))
  ).

  set(redX:=
    (!id_right_unit _)@
    ((id_refl _)[@](!id_right_inverse _))@
    (!assoc _ _ _)@
    (
      (assoc_is_natural (id_refl (id_right_unit p))
                        (id_right_unit a[@]id_left_unit b)
                        (id_refl (!id_right_unit r)))[@]
      (id_refl (!assoc (id_right_unit p) (a @ b) (!id_right_unit r)))
    )@
    ( (id_refl _)[@](!dualize (assoc_is_left_monoidal (a@b) (!id_right_unit r))) )@
    (id_right_unit _)@
    ( (assoc_is_left_monoidal _ _)[@](id_refl _) )@
    (id_left_unit _)
  ).

  set(redP:=
    (id_refl (PI_partR a b))@
    (
       (
          (assoc_is_left_monoidal a (!id_right_unit q)) [[@]]
          (id_refl (id_refl (id_right_unit q @ b @ !id_right_unit r)))
       )[@]
       (
          assoc_is_left_monoidal (a @ !id_right_unit q) (id_right_unit q @ b @ !id_right_unit r)
       )[@]
       (id_refl _)[@]
       (
          !dualize (assoc_is_left_monoidal ((a @ !id_right_unit q) @ (id_right_unit q @ b)) (!id_right_unit r))
       )[@]
       ( (id_refl _)[[@]]redH[[@]](id_refl _) )
    )@
    ( ((id_right_unit _)@(id_left_unit _)) [@] (id_refl _) )@
    ( (id_refl _)[@]redX )@
    ( !interchange (id_refl (id_right_unit p)) (id_refl (id_right_unit p)) (!assoc va vb _) _)@
    (
      (id_left_unit (id_refl (id_right_unit p))) [[@]]
      (
        (
          (!dualize (assoc_is_right_monoidal va vb))@(inv_dist _ _)[@]
          (concat2_is_right_unital _)
        )@
        (!assoc (_@_) (_@_) _)@
        ((!assoc (_@_) _ _)[@](id_refl _))@
        ((assoc _ _ _)[@](id_refl _)[@](id_refl _))@
        (( (inv_dist2 _ _)@((id_refl _)[[@]](inv_sq _)) )[@](id_left_inverse _)[@](id_refl _)[@](id_refl _))@
        ((id_right_unit _)[@](id_refl _)[@](id_refl _))@
        ((!interchange (!id_refl va) (id_right_unit a) (id_right_unit vb) (id_left_unit b))[@](id_refl _))
      )
    )
  ).

  set(redA:=
    (
      (
        redP@
        (interchange
           (id_refl (id_right_unit p))
           (id_refl (id_right_unit p))
           (!id_refl va @ id_right_unit a[@]id_right_unit vb @ id_left_unit b)
           (!id_right_unit (a@b))
        )@
        ((id_refl _)[@]
         (
           (concat2_is_left_unital (!id_right_unit (a @ b)))@
           ((id_left_unit_is_identity _) [@] (id_refl _) [@] (!dualize (id_left_unit_is_identity _)))@
           (id_right_unit _)@(id_left_unit _)
         )
        )
      )[@](id_refl (id_right_unit (a@b)))
    )@(assoc _ _ _)@((id_refl _)[@](id_left_inverse _))@(id_right_unit _)
  ).

  exact(
    ((PIR_proto a b)[@](id_refl (id_right_unit (a @ b)))) @
    (assoc _ (PI_partR a b) (id_right_unit (a @ b)))@
    ((id_refl _)[@](
      redA@(concat2_is_left_unital _)@
      ((id_left_unit_is_identity _) [@] (id_refl _) [@] (!dualize (id_left_unit_is_identity _)))
      @(id_right_unit _)@(id_left_unit _)@
      ((id_left_unit _)[[@]](
          (!id_right_unit_is_natural (id_left_unit b))@
          (((id_left_unit_is_identity _)[[@]](id_refl _))[@](id_refl _))@(id_left_unit _)
      ))
    ))@
    (assoc _ _ _)@((id_refl _)[@](!interchange _ _ _ _))
  ).
Defined.

Definition assoc_rr_inv {A} {x y z:A} (p:x==y) (q:y==z) : (p @ q) @ !q == p.
Proof.
  exact (((assoc p q (!q))@(concat2 (id_refl p) (id_right_inverse q)))@(id_right_unit p)).
Defined.

Definition assoc_rl_inv {A} {x y z:A} (p:x==y) (q:z==y) : (p @ !q) @ q == p.
Proof.
  exact ((concat2 (id_refl (p @ !q)) (!inv_sq q))@(assoc_rr_inv p (!q))).
Defined.

Definition assoc_ll_inv {A} {x y z:A} (p:x==y) (q:y==z) : !p @ (p @ q) == q.
Proof.
  exact (((!assoc (!p) p q)@(concat2 (id_left_inverse p) (id_refl _)))@(id_left_unit q)).
Defined.

Definition assoc_lr_inv {A} {x y z:A} (p:y==x) (q:y==z) : p @ (!p @ q) == q.
Proof.
  exact ((concat2 (!inv_sq p) (id_refl (!p @ q)))@(assoc_ll_inv (!p) q)).
Defined.

Definition inv_idrefl {A} (x : A) : !(id_refl x) == id_refl x.
Proof.
  apply id_refl.
Defined.

Definition inv_idl_dist2 {A} {x y z:A} (p:x == y) {q r:y == z} (X:q==r) : !((id_refl p)[@]X) ==
  (id_refl p[@]!X).
Proof.
  exact ((inv_dist2 (id_refl p) X)@((inv_idrefl p) [[@]] (id_refl (!X)))).
Defined.

Definition inv_idr_dist2 {A} {x y z:A} {p q:x == y} (r:y == z) (X:p==q) : !(X[@](id_refl r)) == (!X
  [@] id_refl r).
Proof.
  exact ((inv_dist2 X (id_refl r))@(id_refl (!X) [[@]] inv_idrefl r)).
Defined.

Definition inv_dist3 {A} {x y z:A} {p q:x==y} {r s:y==z} {X Y:p==q} {Z W:r==s} (a:X==Y) (b:Z==W) : !(a[[@]]b)==(!a[[@]]!b).
  induction a.
  induction b.
  apply id_refl.
Defined.

Definition concat3_dist {A} {x y z:A} {p q:x==y} {r s:y==z} {X Y Z:p==q} {U V W:r==s} (a:X==Y)
  (b:Y==Z) (c:U==V) (d:V==W):
  (a@b)[[@]](c@d) == (a[[@]]c)@(b[[@]]d).
  induction a; induction b; induction c; induction d; apply id_refl.
Defined.

Definition concat4 {A} {x y z:A} {p q:x==y} {r s:y==z} {X Y:p==q} {Z W:r==s} {a b:X==Y} {c d:Z==W} : a==b -> c==d -> a [[@]] c==b [[@]] d.
  intros f g.
  induction f ;induction g.
  apply id_refl.
Defined.

Notation "p [[[@]]] q" := (concat4 p q) (at level 63).

Definition id_save2 {A} {x y z:A} {p q:x==y} {r s:y==z} (X:p==q) (Y:r==s) :
  (id_refl X) [[@]] (id_refl Y) == id_refl (X[@]Y).
  induction X;induction Y;apply id_refl.
Defined.

Definition interchange_is_dinatural {A} {x y z:A} {p q r:x==y} {s t u:y==z} {a a':p==q} {b b':q==r} {c c':s==t} {d d':t==u} (f:a==a') (g:b==b') (h:c==c') (l:d==d'):
  (f[@]g [[@]] h[@]l)@(interchange a' b' c' d')==(interchange a b c d)@((f[[@]]h)[@](g[[@]]l)).
Proof.
  induction f.
  induction g.
  induction h.
  induction l.
  exact (((id_save _ _ [[[@]]] id_save _ _) @ id_save2 _ _ [@] id_refl _)
           @ id_left_unit _
           @ !id_right_unit _
           @ (id_refl _ [@] !id_save _ _
                      @ (!id_save2 _ _ [[@]] !id_save2 _ _))).
Defined.

Definition concat2_left_unit {A} {x:A} {p q:(id_refl x)==(id_refl x)} (f:p==q): (id_refl (id_refl (id_refl x))) [@] f == f.
Proof.
  exact(concat2_is_left_unital f
                               @ ((id_left_unit_is_identity _ [@] id_refl _)
                                    @ id_left_unit _
                                    [@] dualize (!id_left_unit_is_identity _) @ inv_idrefl _)
                               @ id_right_unit _).
Defined.

Definition hexagonR {A} {x:A} (a b c:(id_refl x)==(id_refl x)) :
  (assoc a b c) @ (comm a (b@c)) @ (assoc b c a) ==
     ((comm a b) [@] (id_refl c)) @ (assoc b a c) @ ((id_refl b) [@] (comm a c)).
Proof.
  assert(H1:(id_refl (b@a)[@](id_refl c))==id_refl _) by (apply id_refl).
  assert(H2:(id_refl b)[@](id_refl (c @ a)) == id_refl (b@(c@a))) by (apply id_refl).
  set (e:=id_refl (id_refl x)).
  set(LA:=concat2_is_left_unital_pt a).
  set(RB:=concat2_is_right_unital_pt b).
  set(RC:=concat2_is_right_unital_pt c).

  set(R1:=
        ((PIR b c)[[@]](id_refl LA))@
      (interchange _ (RB[@]RC) (id_refl (e[@]a)) LA)
  ).

  set(L1:=
        ( ((id_refl LA)[[@]](PIR b c))[@](id_refl (!assoc a b c)) )@
        ( (interchange (id_refl (e[@]a)) LA _ (RB[@]RC))[@](id_refl (!assoc a b c)) )@
        (assoc _ _ (!assoc a b c))@
        ( (id_refl _)[@]
          (
              ((!id_left_inverse _)[@](id_refl (LA[@](RB[@]RC)))[@](id_refl _))@
              ((assoc _ _ _)[@](id_refl _))@
              ((id_refl (!assoc (e[@]a) (b[@]e) (c[@]e)))[@](!assoc_is_natural LA RB RC)[@](id_refl (!assoc a b c)))@
              (assoc _ (_@_) _)@
              ((id_refl _)[@](assoc _ _ _))@
              ((id_refl _)[@]((id_refl _)[@](id_right_inverse _)))@
              ((id_refl _)[@](id_right_unit _))
           )
        )@
        (!assoc _ _ _)
   ).

   set(L2:=
      ((id_refl (interchange e (b @ c) a (e @ e)))[@]L1)@
      (!assoc _ (_@_) _)@((!assoc _ _ _)[@](id_refl (LA[@]RB[@]RC)))@
      ((MF3 e b c a e e)[@](id_refl _))
   ).

  set(T1:=
     (!id_right_unit _)@
     ((id_refl _)[@](!H1))@
     ((id_refl _)[@]((!id_left_unit _)[[@]](!id_left_inverse RC)))@
     ((id_refl _)[@](interchange _ _ (!RC) RC))@
     (!assoc ((comm a b)[@](id_refl c)) ((id_refl (b@a))[@](!RC)) ((id_refl (b@a)[@]RC)))@
     (
       (
         (!interchange (comm a b) (id_refl _) (id_refl _) (!RC))@
         ((id_right_unit (comm a b))[[@]](id_left_unit (!RC)))@
         ((!id_left_unit (comm a b))[[@]](!id_right_unit (!RC)))@
         (interchange (id_refl _) (comm a b) (!RC) (id_refl _))
       )[@](id_refl _)
     )@
     ((id_refl _)[@](interchange _ _ (id_refl _) (id_refl _))[@](id_refl _))@
     ((!assoc _ _ _)[@](id_refl _))@(assoc (_@_) _ _)@
     ((!interchange _ _ _ _)[@](!interchange _ _ _ _))@
     (((id_left_unit _)[[@]](id_refl _))[@]((id_right_unit _)[[@]](id_refl _)))@
     ((interchange (!(LA[@]RB)) _ (!RC) (id_refl (c[@]e)))[@](interchange _ (RB[@]LA) (id_refl (c[@]e)) RC))@
     (((!inv_dist2 (LA[@]RB) RC)[@](id_refl _))[@](id_refl _))@
     (!assoc (_@_) _ _)@((assoc _ _ _)[@](id_refl _))
   ).

   set(T2:=
     (!id_right_unit _)@
     ((id_refl _)[@](!H2))@
     ((id_refl _)[@]((!id_left_inverse RB)[[@]](!id_left_unit _)))@
     ((id_refl _)[@](interchange (!RB) RB _ _))@
     (!assoc ((id_refl b)[@](comm a c)) ((!RB)[@](id_refl (c@a))) (RB[@](id_refl (c@a))))@
     (
       (
         (!interchange (id_refl b) (!RB) (comm a c) (id_refl _))@
         ((id_left_unit (!RB))[[@]](id_right_unit _))@
         ((!id_right_unit (!RB))[[@]](!id_left_unit _))@
         (interchange _ _ _ _)
       )[@](id_refl _)
     )@
     ((id_refl _)[@](interchange (id_refl (b[@]e)) (id_refl (b[@]e)) _ _)[@](id_refl _))@
     ((!assoc _ _ _)[@](id_refl _))@
     (assoc (_@_) _ _)@
     ((!interchange (!RB) (id_refl (b[@]e)) (id_refl _) _)[@](!interchange (id_refl (b[@]e)) RB _ _))@
     (((id_refl _)[[@]](id_left_unit _))[@]((id_refl _)[[@]](id_right_unit _)))@
     ((interchange (!RB) (id_refl (b[@]e)) _ _)[@](interchange _ RB _ (RC[@]LA)))@
     (((!inv_dist2 RB (LA[@]RC))[@](id_refl _))[@](id_refl _))@
     (assoc _ _ (_@_))@((id_refl _)[@](!assoc _ _ _))
   ).

   set(T3:=
     (T1[@](id_refl (assoc b a c))[@]T2)@
     ((assoc (_@(_@_)) _ _)[@](id_refl _))@
     (assoc _ _ _)@((id_refl (_@(_@_)))[@](!assoc (_@_) _ _))@
     (
       (id_refl _)[@](
       (
           ((assoc_is_natural RB LA RC)[@](id_refl (!(RB[@](LA[@]RC)))))@
           (assoc _ _ _)@
           ((id_refl _)[@](id_right_inverse _))@
           (id_right_unit _)
       )[@]
       (id_refl _))
     )@
     ((id_refl _)[@](!assoc _ _ _))@
     (!assoc _ _ _)
   ).

   (* Note: M1は(MF3 b e c e a e)を変形するだけ *)
   assert(M1 : (interchange b e e a[@]id_refl (c[@]e))@
               (assoc (b[@]e) (e[@]a) (c[@]e))@
               (id_refl (b[@]e)[@]!interchange e c a e)==
               (!interchange (b @ e) c (e @ a) e)@
               (assoc b e c[[@]]assoc e a e)@
               (interchange b (e @ c) e (a @ e)) ).

   exact ((!(((((id_refl ((!(interchange (b @ e) c (e @ a) e)) @ (assoc b e c[[@]]assoc e a e)))
                  [@]
                  ((((!assoc_rl_inv (interchange b (e @ c) e (a @ e)) (id_refl (b[@]e)[@]!interchange e c a e))
                       @
                       (concat2
                          ((concat2
                              (id_refl (interchange b (e @ c) e (a @ e)))
                              ((dualize ((inv_idrefl (b[@]e))[[@]](id_refl (!interchange e c a e))))
                                 @
                                 ((dualize (inv_dist2 (id_refl (b[@]e)) (interchange e c a e)))
                                    @
                                    (inv_sq (id_refl (b[@]e)[@]interchange e c a e)))))
                             @
                             ((!assoc_rl_inv ((interchange b (e @ c) e (a @ e)) @ (id_refl (b[@]e)[@]interchange e c a e)) (assoc (b[@]e) (e[@]a) (c[@]e)))
                                @
                                (concat2
                                   (MF3 b e c e a e)
                                   (id_refl (assoc (b[@]e) (e[@]a) (c[@]e))))))
                          (id_refl (id_refl (b[@]e)[@]!interchange e c a e))))
                      @
                      (assoc ((!(assoc b e c[[@]]assoc e a e) @ (interchange (b @ e) c (e @ a) e)) @ (interchange b e e a[@]id_refl (c[@]e))) (assoc (b[@]e) (e[@]a) (c[@]e)) (id_refl (b[@]e)[@]!interchange e c a e)))
                     @
                     (assoc (!(assoc b e c[[@]]assoc e a e) @ (interchange (b @ e) c (e @ a) e)) (interchange b e e a[@]id_refl (c[@]e)) ((assoc (b[@]e) (e[@]a) (c[@]e)) @ (id_refl (b[@]e)[@]!interchange e c a e)))))
                 @
                 ((!((inv_dist (!(assoc b e c[[@]]assoc e a e)) (interchange (b @ e) c (e @ a) e))@((id_refl (!(interchange (b @ e) c (e @ a) e))) [@] (inv_sq (assoc b e c[[@]]assoc e a e)))))
                    [@] (id_refl ((!(assoc b e c[[@]]assoc e a e) @ (interchange (b @ e) c (e @ a) e)) @ ((interchange b e e a[@]id_refl (c[@]e)) @ ((assoc (b[@]e) (e[@]a) (c[@]e)) @ (id_refl (b[@]e)[@]!interchange e c a e)))))))
                @
                (assoc_ll_inv (!(assoc b e c[[@]]assoc e a e) @ (interchange (b @ e) c (e @ a) e)) ((interchange b e e a[@]id_refl (c[@]e)) @ ((assoc (b[@]e) (e[@]a) (c[@]e)) @ (id_refl (b[@]e)[@]!interchange e c a e)))))
               @
               (!assoc (interchange b e e a[@]id_refl (c[@]e)) (assoc (b[@]e) (e[@]a) (c[@]e)) (id_refl (b[@]e)[@]!interchange e c a e))))).

   (* Note: M2は(!dualize (MF3 e b c a e e))を変形 *)
   assert(M2 : (!interchange e b a e[@]id_refl (c[@]e))@
               (!interchange (e @ b) c (a @ e) e)@
               (assoc e b c[[@]]assoc a e e) ==
               (assoc (e[@]a) (b[@]e) (c[@]e))@
               (id_refl (e[@]a)[@]!interchange b c e e)@
               (!interchange e (b @ c) a (e @ e)) ).

   exact(
       ((id_refl ((!interchange e b a e[@]id_refl (c[@]e)) @ (!interchange (e @ b) c (a @ e) e)))
          [@] (!inv_sq (assoc e b c[[@]]assoc a e e)))
         @
         (assoc (!interchange e b a e[@]id_refl (c[@]e)) (!(interchange (e @ b) c (a @ e) e)) (!!(assoc e b c[[@]]assoc a e e)))
         @
         ((!inv_idr_dist2 (c[@]e) (interchange e b a e))[@](!inv_dist (!(assoc e b c[[@]]assoc a e e)) (interchange (e @ b) c (a @ e) e)))
         @
         (!inv_dist ((!(assoc e b c[[@]]assoc a e e)) @ (interchange (e @ b) c (a @ e) e)) (interchange e b a e[@]id_refl (c[@]e)))
         @
         (dualize (MF3 e b c a e e))
         @
         (inv_dist ((interchange e (b @ c) a (e @ e)) @ (id_refl (e[@]a)[@]interchange b c e e)) (!(assoc (e[@]a) (b[@]e) (c[@]e))))
         @
         ((inv_sq (assoc (e[@]a) (b[@]e) (c[@]e)))[@](inv_dist (interchange e (b @ c) a (e @ e)) (id_refl (e[@]a)[@]interchange b c e e)))
         @
         (id_refl (assoc (e[@]a) (b[@]e) (c[@]e)) [@] ((inv_idl_dist2 (e[@]a) (interchange b c e e)) [@] (id_refl (!(interchange e (b @ c) a (e @ e))))))
         @
         (!assoc (assoc (e[@]a) (b[@]e) (c[@]e)) (id_refl (e[@]a)[@]!interchange b c e e) (!(interchange e (b @ c) a (e @ e))))).

   assert(M3 : (interchange b (c @ e) e (e @ a)@
               (id_refl (b[@]e)[@]interchange c e e a))@
               (!assoc (b[@]e) (c[@]e) (e[@]a)) ==
               (!(assoc b c e[[@]]assoc e e a))@
               (interchange (b @ c) e (e @ e) a) @
               (interchange b c e e[@]id_refl (e[@]a)) ).
   exact (MF3 b c e e e a).

   assert (M4 : ((comm a b[@]id_refl c) @ assoc b a c) @ (id_refl b[@]comm a c) ==
                (((!((LA[@]RB)[@]RC)
                    @ (!((!id_left_unit b[[@]]!id_right_unit a) @ interchange e b a e)
                        [@] id_refl (c[@]e)))
                    @ ((!id_right_unit b[[@]]!id_left_unit a)[@] id_refl (c[@]e)))
                   @ (
                     ((!interchange (b @ e) c (e @ a) e @ (assoc b e c[[@]]assoc e a e))
                        @ interchange b (e @ c) e (a @ e))
                       @ ((id_refl (b[@]e) [@] !(!id_left_unit c[[@]]!id_right_unit a))
                            @ (id_refl (b[@]e)
                                       [@] (!id_right_unit c[[@]]!id_left_unit a)
                                       @ interchange c e e a))))
                  @ (RB[@](RC[@]LA))).
   exact(T3
           @ (id_refl _[@](id_refl _[@]distr _ _ _)
                      [@](id_refl _
                                  [@](((id_refl _ [[@]] inv_dist _ _) @ distl _ _ _)
                                        [@]id_refl _))
                      [@]id_refl _)
           @ (!assoc _ _ _ @ !assoc _ _ _[@] (id_refl _ [@] assoc _ _ _) [@]id_refl _)
           @ (assoc _ _ _ [@] id_refl _)
           @ (id_refl _ [@] !assoc _ _ _ @ !assoc _ _ _ [@] id_refl _)
           @ (id_refl _ [@] (M1 [@] id_refl _) [@] id_refl _)).

   assert (M5 :
             ((comm a b[@]id_refl c) @ assoc b a c) @ (id_refl b[@]comm a c) ==
             (((!((LA[@]RB)[@]RC)
                 @ (!((!id_left_unit b[[@]]!id_right_unit a) @ interchange e b a e)
                     [@] id_refl (c[@]e)))
                 @ ((!id_right_unit b[[@]]!id_left_unit a)[@] id_refl (c[@]e)))
                @ (
                  ((!interchange (b @ e) c (e @ a) e
                     @ (((id_right_unit b)[@](id_refl c) [[@]] (id_left_unit a)[@] (id_refl e))
                          @ ((!id_left_unit b)[@](id_refl c) [[@]] (!id_right_unit a)[@] (id_refl e))
                          @ (assoc e b c[[@]]assoc a e e)))
                     @ interchange b (e @ c) e (a @ e))
                    @ ((id_refl (b[@]e) [@] !(!id_left_unit c[[@]]!id_right_unit a))
                         @ (id_refl (b[@]e)
                                    [@] (!id_right_unit c[[@]]!id_left_unit a)
                                    @ interchange c e e a))))
               @ (!assoc (b[@]e) (c[@]e) (e[@]a) @ (((RB[@]RC)[@]LA) @ (assoc b c a)))
          ).

   exact(M4
           @ (id_refl _
                      [@] (id_refl _
                                   [@] !((!concat3_dist _ _ _ _ [@] (id_refl (assoc e b c[[@]]assoc a e e)))
                                           @ (!concat3_dist _ _ _ _)
                                           @ ((((id_refl _) [@] (!(dualize (id_left_unit_is_identity b))[[@]] (id_refl _))
                                                            [@] (assoc_is_left_monoidal _ _))
                                                 @ (id_right_unit _)
                                                 @ ((id_refl _) [@] ((inv_idrefl b) [[@]] (id_refl _)))
                                                 @ ((id_refl _) [@] (id_save b _))
                                                 @ (id_right_unit _)
                                                 @ (!assoc_is_center_monoidal b c))
                                                [[[@]]] ((((id_left_unit_is_identity _)[[@]] (id_refl _))
                                                            [@] ((id_refl _) [[@]] (!inv_idrefl e))
                                                            [@] (id_refl _))
                                                           @ ((id_save a e) [@] (!inv_dist2 _ _) [@] (id_refl _))
                                                           @ ((!assoc_is_left_monoidal a e) [@] (dualize (assoc_is_center_monoidal a e)) [@] (id_refl _))
                                                           @ (assoc_rl_inv _ _))))
                                   [@] id_refl _ [@] id_refl _)
                      [@] (!assoc_ll_inv _ _) @ (id_refl _ [@] !assoc_is_natural _ _ _))).

   assert (M6 :
             (!(!id_left_unit b[[@]]!id_right_unit a) [@] id_refl (c[@]e))
               @ (((!id_right_unit b[[@]]!id_left_unit a)[@] id_refl (c[@]e))
                    @ !interchange (b @ e) c (e @ a) e
                    @ ((id_right_unit b[@]id_refl c [[@]] id_left_unit a[@] id_refl e)
                         @ (!id_left_unit b[@]id_refl c [[@]] !id_right_unit a[@]id_refl e)))
             ==
             !interchange (e @ b) c (a @ e) e).
   exact (!assoc _ _ _
           @ (!assoc _ _ _ @ (!distr _ _ _
                               @ ((inv_dist3 _ _
                                             [@] id_refl _) @ !concat3_dist _ _ _ _
                                                            @ (!inv_dist _ _ [[[@]]] !inv_dist _ _)
                                                            @ !inv_dist3 _ _
                                                            [[@]] !id_save2 c e
                                                            @ !inv_sq _
                                                            @ dualize (!inv_dist3 _ _))
                               [@] id_refl _) [@] id_refl _)
           @ ((!inv_dist2 _ _ [@] id_refl _) @ !inv_dist _ _
                                             @ dualize (interchange_is_dinatural _ _ _ _)
                                             @ inv_dist _ _
                                             [@] !concat3_dist _ _ _ _
                                             @ (!distr _ _ _
                                                 @ (id_refl _ [[@]] !inv_idrefl _)
                                                 [[[@]]] !distr _ _ _
                                                 @ (id_refl _ [[@]] !inv_idrefl _)))
           @ assoc_rl_inv _ _).

   assert (M7 :
             interchange b (e @ c) e (a @ e)
                         @ (id_refl (b[@]e) [@] (!(!id_left_unit c[[@]]!id_right_unit a)))
                         @ (id_refl (b[@]e) [@] (!id_right_unit c[[@]]!id_left_unit a))
             ==
             ((id_refl b [@] id_left_unit c)[[@]](id_refl e [@] id_right_unit a))
               @ ((id_refl b [@] !id_right_unit c)[[@]](id_refl e [@] !id_left_unit a))
               @ interchange b (c @ e) e (e @ a)).
   exact (assoc _ _ _
                @ (id_refl _ [@] !distl _ _ _ @ (id_save2 _ _ [[@]] id_refl _))
                @ (id_refl _ [@] (id_refl _ [[@]] (inv_dist3 _ _ @ (inv_sq _ [[[@]]] inv_sq _)
                                                             [@] id_refl _)
                                          @ !concat3_dist _ _ _ _))
                @ !interchange_is_dinatural (id_refl b) _ (id_refl e) _
                @ ((distl _ _ _ [[[@]]] distl _ _ _)
                     @ concat3_dist _ _ _ _
                     [@] id_refl _ )).

   assert (M8 :
             ((comm a b[@]id_refl c) @ assoc b a c) @ (id_refl b[@]comm a c) ==
             (((!((LA[@]RB)[@]RC)
                 @ (!interchange e b a e [@] id_refl (c[@]e)))
                 @ (
                   !interchange (e @ b) c (a @ e) e
                    @ (assoc e b c[[@]]assoc a e e)))
                @ (((((id_refl b [@] id_left_unit c)[[@]](id_refl e [@] id_right_unit a))
                       @ ((id_refl b [@] !id_right_unit c)[[@]](id_refl e [@] !id_left_unit a)))
                      @ interchange b (c @ e) e (e @ a))
                     @ (id_refl (b[@]e) [@] interchange c e e a)))
               @ (!assoc (b[@]e) (c[@]e) (e[@]a) @ (((RB[@]RC)[@]LA) @ (assoc b c a)))).
   exact (M5
            @ (id_refl _ [@] (inv_dist _ _ [[@]] id_refl _) @ distr _ _ _
                       [@] id_refl _
                       [@] (id_refl _ [@] (id_refl _ [@] distl _ _ _))
                       [@] id_refl _)
            @ (!assoc _ _ _ @ (!assoc _ _ _ [@] id_refl _) @ assoc _ _ _[@] id_refl _)
            @ (assoc _ _ _ @ (!assoc _ _ _ [@] !assoc _ _ _ @ !assoc _ _ _)
                     [@] !assoc _ _ _ @ !assoc _ _ _[@] id_refl _)
            @ (assoc _ _ _ @ (id_refl _ [@] !assoc _ _ _) [@] id_refl _ [@] id_refl _)
            @ (id_refl _ [@] (M6 [@] id_refl _) [@] (M7 [@] id_refl _) [@] id_refl _)).

   assert (M9 : (comm a (b@c))
                == !(LA[@]concat2_is_right_unital_pt (b@c))
                    @ !((!id_left_unit (b@c)[[@]]!id_right_unit a)
                          @ interchange e (b@c) a e)
                    @ (((!id_right_unit (b@c)[[@]]!id_left_unit a)
                          @ interchange (b@c) e e a)
                         @ (concat2_is_right_unital_pt (b@c)[@]LA))).
   apply id_refl.

   exact(!(M8
             @ (assoc _ _ _ @ (id_refl _ [@] !assoc _ _ _ @ M2) [@] assoc _ _ _ [@] id_refl _)
             @ assoc _ _ _
             @ (id_refl _ [@] assoc _ _ _ @ (id_refl _ [@] !assoc _ _ _ @ (M3 [@] id_refl _)))
             @ (!assoc _ _ _ @ (!assoc _ _ _ [@] id_refl _) [@] id_refl _)
             @ ((inv_dist2 _ _ @ (inv_dist2 _ _ [[@]] id_refl _ ) [@] id_refl _)
                  @ assoc_is_natural _ _ _
                  [@] id_refl _ [@] id_refl _ [@] id_refl _)
             @ !assoc _ _ _ @ !assoc _ _ _ @ !assoc _ _ _
             @ (assoc _ _ _ @ assoc _ _ _ @ assoc _ _ _ @ assoc _ _ _ @ assoc _ _ _ [@] id_refl _)
             @ (id_refl _
                        [@] (!assoc _ _ _
                              @ (!interchange _ _ _ _
                                  @ (id_right_unit _ [[@]] (!inv_dist2 _ _ [@] id_refl _ ) @ !inv_dist _ _ @ dualize (PIR _ _))
                                  [@] (id_refl _
                                               [@] (id_refl _
                                                            [@] assoc _ _ _
                                                            @ (inv_dist3 _ _ @ (dualize (!assoc_is_right_monoidal _ _) @ inv_dist _ _ [[[@]]] dualize (!assoc_is_left_monoidal _ _) @ dualize (id_left_unit_is_identity _) @ !id_left_unit _)
                                                                         @ concat3_dist _ _ _ _
                                                                         [@] id_refl _
                                                                         [@] !interchange _ _ _ _ @ (!PIR _ _ [[@]] id_left_unit _)))))
                              @ (id_refl _ [@] !assoc _ _ _
                                         @ (id_refl _ [@] assoc _ _ _ @ assoc _ _ _)
                                         @ !assoc _ _ _
                                         @ (assoc _ _ _ @ (id_refl _ [@] assoc _ _ _)
                                                  [@] !assoc _ _ _))
                              @ (id_refl _ [@] (id_refl _
                                                        [@] (((id_refl _ [[@]] id_left_unit_is_identity _) @ id_save _ _
                                                                                [[[@]]] concat2_left_unit (id_right_unit a))
                                                               [@] ((id_refl _ [[[@]]] concat2_left_unit (!id_left_unit a) @ dualize (!id_left_unit_is_identity _))
                                                                      [@] (id_refl _ [[[@]]] !inv_sq _) @ !inv_dist3 _ _)
                                                               @ id_right_inverse _)
                                                        @ id_right_unit _
                                                        [@] id_refl _))
                              @ (!inv_dist2 _ _ [@] ((id_refl _ [@] (!id_left_unit_is_identity (b@c) @ !inv_sq _ [[[@]]] !inv_sq _) @ !inv_dist3 _ _)
                                                       @ !inv_dist _ _
                                                       [@] id_refl _))
                              @ !assoc _ _ _)
                        @ !M9
                        [@] id_refl _))).
Defined.

(* FIXME:hexagonRと同様にして示す *)
Definition hexagonL {A} {x:A} (a b c:(id_refl x)==(id_refl x)) :
  (!assoc a b c)@(comm (a@b) c)@(!assoc c a b)==
    ((id_refl a)[@](comm b c))@(!assoc a c b)@((comm a c)[@](id_refl b)).
Proof.
Admitted.

(* Yang-Baxter equation *)
Definition YBE {A} {x:A} (a b c:(id_refl x)==(id_refl x)) :
  ((comm a b)[@](id_refl c)) @ (assoc b a c) @
  ((id_refl b)[@](comm a c)) @ (!assoc b c a) @
  ((comm b c)[@](id_refl a)) @ (assoc c b a) ==
  (assoc a b c) @ ((id_refl a)[@](comm b c)) @
  (!assoc a c b) @ ((comm a c)[@](id_refl b)) @
  (assoc c a b) @ ((id_refl c)[@](comm a b)).
Proof.
  (* N : comm a (b @ c) @ (comm b c[@]id_refl a) == (id_refl a[@]comm b c) @ comm a (c @ b) *)
  set(N := !comm_is_dinatural (id_refl a) (comm b c)).

  set(BX := !((hexagonR a b c)[@](id_refl (!assoc b c a)))@(assoc_rr_inv _ (assoc b c a)) ).

  set(BY := (!assoc_ll_inv (assoc a c b) _)@
             ((id_refl (!assoc a c b))[@]((!assoc _ _ _)@(hexagonR a c b)))@
             (!assoc _ _ _)@((!assoc _ _ _)[@](id_refl _)) ).

  set(P := (BX [@] (id_refl (comm b c[@]id_refl a)))@
           (assoc _ _ _)@
           ((id_refl (assoc a b c))[@]N)
     ).

  exact (
    (P [@] (id_refl (assoc c b a)))@
    ( (!assoc _ _ _)[@](id_refl _) )@(assoc _ _ _)@
    ( (id_refl _)[@]BY)@
    (!assoc _ _ _)@
    ((!assoc _ _ _)[@](id_refl _))@
    ((!assoc _ _ _)[@](id_refl _)[@](id_refl _))
  ).

Defined.

(*
MEMO:YBEがZamolodchikov tetrahedron equationを満たすこと

((YBE a b c)[@](id_refl d))[[@]]???? : (1)==(2)
???[[@]]???[[@]]((id_refl c)[@](YBE a b d))[[@]]??? : (2)==(3)

(4)==(4.5) from ((id_refl a)[@](YBE b c d))
(4.5)==(5) from naturality of comm

(1)(ABC)D->(BAC)D->(BCA)D->(CBA)D->CBDA->CDBA->DCBA
(2)(ABC)D->(ACB)D->(CAB)D->(CBA)D->CBDA->CDBA->DCBA
(3)(ABC)D->(ACB)D->CABD->CADB->CDAB->CDBA->DCBA
(3.5)
(4)ABCD->ACBD->ACDB->ADCB->DACB->DCAB->DCBA
(4.5)ABCD->ABDC->ADBC->ADCB->DACB->DCAB->DCBA
(5)ABCD->ABDC->ADBC->DABC->DACB->DCAB->DCBA

(1')=(1)
(2')ABCD->BACD->BCAD->BCDA->BDCA->DBCA->DCBA
(3')ABCD->BACD->BADC->BDAC->DBAC->DBCA->DCBA
(4')ABCD->ABDC->ADBC->DABC->DBAC->DBCA->DCBA
(5')=(5)

References:
[1]Kapranov and Voevodsky ,2-categories and Zamolodchikov tetrahedra equations, in Algebraic Groups and Their Generalizations

*)

(*
(pivotal) monoidal categoryに於けるcategorical trace
Q1: left traceとright traceがあるけど、一致する？
多分、Whitehead bracketは、
WB x y := trace ((comm x y)@(comm y x))
Whitehead half-square mapは、
WM x := trace (comm x x)
Q2: (WB x y)@(WM x)@(WM y) == WM (x@y)が言える?

Q3: n-基本亜群(n>2)に於ける標準的なWhitehead積$\pi_2 \times \pi_2 \to \pi_3$とこの定義が一致することの証明

Reference: Fusion categories and homotopy theory(arXiv:0909.3140) Chapter7.3

*)

Definition trace {A} {x:A} {a:id_refl x==id_refl x} (f:a==a) :=
  (!id_right_inverse a) @ (f [@] (id_refl (!a))) @
  ((!inv_sq a)[@](id_refl (!a))) @ (id_left_inverse (!a)).


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

 Limits in the enriched opposite category

 If an enriched category has colimits, then its opposite inherits
 these as limits.

 Contents
 1. Terminal object
 2. Binary products
 3. Equalizers
 4. Type indexed products
 5. Powers

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.OppositeCategory.Core.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.OppositeEnriched.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedTerminal.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedBinaryProducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedProducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedEqualizers.
Require Import UniMath.CategoryTheory.EnrichedCats.Limits.EnrichedPowers.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedInitial.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedBinaryCoproducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoproducts.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCoequalizers.
Require Import UniMath.CategoryTheory.EnrichedCats.Colimits.EnrichedCopowers.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Symmetric.
Require Import UniMath.CategoryTheory.Monoidal.Structure.Closed.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.equalizers.

Local Open Scope cat.
Local Open Scope moncat.
Import MonoidalNotations.

Section OppositeLimits.
  Context {V : sym_monoidal_cat}
          {C : category}
          (E : enrichment C V).

  Let E' : enrichment (C^opp) V := op_enrichment V E.

  (**
   1. Terminal object
   *)
  Definition opposite_terminal_enriched
             (I : initial_enriched E)
    : terminal_enriched E'.
  Proof.
    exact I.
  Defined.

  (**
   2. Binary products
   *)
  Section OppositeBinaryProducts.
    Context {x y : C}
            (s : binary_coprod_enriched E x y).

    Definition opposite_binary_prod_enriched_is_prod
      : is_binary_prod_enriched E' x y (pr1 s).
    Proof.
      intro w.
      use (isBinProduct_eq_arrow _ _ (pr2 s w)).
      - abstract
          (unfold E' ;
           rewrite op_enrichment_postcomp ;
           apply maponpaths ; cbn ;
           apply idpath).
      - abstract
          (unfold E' ;
           rewrite op_enrichment_postcomp ;
           apply maponpaths ; cbn ;
           apply idpath).
    Defined.

    Definition opposite_binary_prod_enriched
      : binary_prod_enriched E' x y.
    Proof.
      simple refine (_ ,, _).
      - exact (pr1 s).
      - exact opposite_binary_prod_enriched_is_prod.
    Defined.
  End OppositeBinaryProducts.

  (**
   3. Equalizers
   *)
  Section OppositeEqualizers.
    Context {x y : C}
            {f g : x --> y}
            (e : coequalizer_enriched E f g).

    Definition opposite_is_equalizer_enriched
      : is_equalizer_enriched E' f g (pr1 e).
    Proof.
      intro w.
      use (isEqualizer_eq _ _ _ _ _ (pr2 e w)).
      - abstract
          (refine (!_) ;
           apply op_enrichment_postcomp).
      - abstract
          (refine (!_) ;
           apply op_enrichment_postcomp).
      - abstract
          (refine (!_) ;
           apply op_enrichment_postcomp).
    Defined.

    Definition opposite_equalizer_enriched : equalizer_enriched E' f g
      := pr1 e ,, opposite_is_equalizer_enriched.
  End OppositeEqualizers.

  (**
   4. Type indexed products
   *)
  Section OppositeProducts.
    Context {J : UU}
            (ys : J → C)
            (s : coprod_enriched E ys).

    Definition opposite_prod_enriched_is_prod
      : is_prod_enriched E' ys (pr1 s).
    Proof.
      intro w.
      use (isProduct_eq_arrow _ (pr2 s w)).
      abstract
        (intro j ;
         unfold E' ;
         rewrite op_enrichment_postcomp ;
         apply maponpaths ; cbn ;
         apply idpath).
    Defined.

    Definition opposite_prod_enriched
      : prod_enriched E' ys.
    Proof.
      simple refine (_ ,, _).
      - exact (pr1 s).
      - exact opposite_prod_enriched_is_prod.
    Defined.
  End OppositeProducts.
End OppositeLimits.

(**
 5. Powers
 *)
Definition opposite_power_enriched
           {V : sym_mon_closed_cat}
           {C : category}
           (E : enrichment C V)
           {v : V} {x : C}
           (e : copower_cocone E v x)
           (He : is_copower_enriched E v x e)
  : is_power_enriched (op_enrichment V E) v x e.
Proof.
  intros w.
  use (is_z_isomorphism_path _ (He w)).
  abstract
    (unfold is_copower_enriched_map, is_power_enriched_map ;
     use internal_funext ;
     intros a h ;
     rewrite tensor_split ;
     rewrite !assoc' ;
     rewrite internal_beta ;
     refine (!_) ;
     rewrite tensor_split ;
     rewrite !assoc' ;
     rewrite internal_beta ;
     do 2 apply maponpaths ;
     cbn -[sym_mon_braiding] ;
     rewrite !assoc ;
     rewrite sym_mon_braiding_inv ;
     apply id_left).
Defined.


(*partie1 *)

Require Import untypedLC.

(*booleans*)
Definition ctr := \ x y·x.
Definition cfa := \ x y· y.
(*boolean functions*)
Definition cif := \ x y z· x y z.
Definition cand := \ a b· \x y · a (b a b)y.
Compute equiv_lexp (cand cfa ctr) cfa.
Definition cor := \a b·\x y·a x(b x  y).
Compute equiv_lexp (cor cfa ctr) ctr.
Definition cneg := \b · b cfa ctr.
Compute equiv_lexp (cneg cfa) ctr.
Definition test := \x · \y · cif ctr x y.

(*codage de quelques constantes 0, 1, 2, 3.*)
Definition c0 := \f x·x.
Definition c1 := \f x ·f x.
Definition c2 := \f x· f ( c1 f x ).
Definition c3 := \f x· f ( c2 f x ).
Definition c4 := \f x· f ( c3 f x ).
Definition c5 := \f x· f ( c4 f x).
(* THE REST IS JUST FOR FUN :-) *)
Definition c6 := \f x· f ( c5 f x).
Definition c7 := \f x· f ( c6 f x).
Definition c8 := \f x· f ( c7 f x).
Definition c9 := \f x· f ( c8 f x).
Definition c10 := \f x· f ( c9 f x).
(*opérations successeur, addition et multiplica-tion,
et du test à 0*)
Definition csucc := \n · \ f x·f(n f x).
(* succ c9 = c10 ? *)
Compute equiv_lexp (csucc c9) c10.
Definition cadd := \n m·\f x·n f(m f x).
(* c9 + c1 = c10 ? *)
Compute equiv_lexp (cadd c9 c1) c10.
Definition cmult := \n m · \f· n(m f).
(* c2 * c5 = c10 ? *)
Compute equiv_lexp (cmult c2 c5) c10.
Definition ceq0 := \n·\x y· n(\z·y) x.
(* c0 = c0 *)
Compute equiv_lexp (ceq0 c0) ctr.
(*couples*)
Definition cpl := \x1 x2 · \k · k x1 x2.

(*operation sur couples*)
(*voir tests au-dessous*)
Definition kfst := \x1 x2 · x1.
Definition ksnd := \x1 x2 · x2.
Definition fst := \c · c  kfst.
Definition snd := \c · c  ksnd.
(*TEST COUPLES*)
Definition cc := cpl c5 c9.
Compute equiv_lexp (cc kfst) c5.
Compute equiv_lexp (cc ksnd) c9.
Compute equiv_lexp (fst cc) c5.
Compute equiv_lexp (snd cc) c9.

(*Injection*)
Definition inj1 := \x · \k l · k x.
Definition inj2 := \x · \k l · l x.
(*INJECTION TEST *)
(*Injected value = number of occurances of the f in the right-side of the equation*)
Compute show_cbn (inj1 (cpl c1 c0) c3).

(*predecesseur*)
(* EXPLICATION :
On prend un entier N.
si N = 1 ou 0. On retourne 0.
Sinon, on ajoute +1 a notre variable SECOND jusqu'a x = n-1
C'est grace a l'usage de couples
i.e : 5 (0,0) -> 5 (0,1) -> 5 (1,2) -> 5 (2,3) -> 5 (3,4) -> 5 (4,5) <=> 4 ! *)
Definition iter := \x · cpl (snd x) (csucc (snd x)).
Definition cpred := \n · fst ( n iter (cpl c0 c0)).
Compute show_cbn (cpred ).
Compute equiv_lexp (cpred c4) c3.
Compute equiv_lexp (cpred c2) c1.
(* PRED DE 0 ?? . IL FAUT RETORUNER  0 !*)
Compute equiv_lexp (cpred c0) c0.

(*factorial*)
(*The Y combinator*)
Definition Y := \f·(\x·f( x x)) (\x · f (x x)).
(*if n = 1, return 1, else cmult n * (n-1)*)
Definition cfonc := \r·\n·cif (ceq0 n) c1 (cmult n (r (cpred n))) .
Definition cfact := Y cfonc.
Compute equiv_lexp (cfact c3) c6.


Require Import bf bf_equivalence bf_semantics.
Require Import Lists.Streams.
Require Import Setoid.
Require Import Arith.

Fixpoint add_n (n : nat) :=
  match n with
    | 0 => END
    | S n => + (add_n n)
  end.

Lemma about_add_n (n : nat) :
  forall ls x rs stdin stdout,
    iter (add_n n, state[ls, x, rs, stdin, stdout])
         (END, state[ls, n+x, rs, stdin, stdout]).
Proof.
  induction n.
  intros.
  bf_step.

  intros.
  bf_step.
  simpl.
  rewrite plus_n_Sm.
  apply IHn.
Qed.

Definition push (n: nat) := > add_n n.

Theorem about_push (n: nat) :
  forall ls x stdin stdout,
    iter (push n, state[ls, x, zeroes, stdin, stdout])
         (END, state[Cons x ls, n, zeroes, stdin, stdout]).
Proof.
  unfold push.
  intros.
  bf_step.
  simpl stepRight.
  rewrite (plus_n_O n) at 2.
  apply about_add_n.
Qed.

Definition add := [- < + >END]<END.

Theorem about_add :
  forall ls y x stdin stdout,
    iter (add, state[Cons x ls, y, zeroes, stdin, stdout])
         (END, state[ls, y+x, zeroes, stdin, stdout]).
Proof.
  unfold add.
  intros ls y.
  induction y.
  intros.
  repeat bf_step.

  intros.
  do 5 bf_step.
  rewrite (plus_n_Sm).
  apply IHy.
Qed.

Definition sub := [- < - >END]<END.

Theorem about_sub :
  forall ls x y stdin stdout,
    iter (sub, state[Cons y ls, x, zeroes, stdin, stdout])
         (END, state[ls, y - x, zeroes, stdin, stdout]).
Proof.
  unfold sub.
  intros ls x.
  induction x.
  intros.
  repeat bf_step.
  rewrite <- minus_n_O.
  bf_step.

  intros.
  do 4 bf_step.
  replace (decrement state[ls, y, Cons x zeroes, stdin, stdout])
  with state[ls, y - 1, Cons x zeroes, stdin, stdout]
    by (destruct y;
        [ reflexivity
        | simpl; rewrite <- minus_n_O; reflexivity ]).
  bf_step.
  replace (y - S x)
  with ((y - 1) - x)
    by (destruct y; [ reflexivity
                   | simpl; rewrite <- minus_n_O; reflexivity ]).
  apply IHx.
Qed.

Definition dup := [> + > + < < -END] (* Add top of stack to the two next cells *)
                  > > (* Move to the result *)
                  [< < + > > -END]<END (* Copy result to top of stack *)
.

Lemma about_dup_lemma1 :
  forall ls x y stdin stdout c,
    iter ([> + > + < < -END]c, state[ls, x, Cons y (Cons y zeroes), stdin, stdout])
         (c, state[ls, 0, Cons (x+y) (Cons (x+y) zeroes), stdin, stdout]).
Proof.
  intros ls x.
  induction x.
  intros.
  repeat bf_step.

  intros.
  do 8 bf_step.
  simpl.
  rewrite plus_n_Sm.
  apply IHx.
Qed.

Lemma about_dup_lemma2 :
  forall ls x y z stdin stdout c,
    iter
      ([< < + > > - END]c,
       state[Cons y (Cons z ls), x, zeroes, stdin, stdout])
      (c, state[Cons y (Cons (x+z) ls), 0, zeroes, stdin, stdout]).
Proof.
  intros ls x.
  induction x.
  intros.
  repeat bf_step.

  intros.
  do 7 bf_step.
  simpl.
  rewrite plus_n_Sm.
  apply IHx.
Qed.

Theorem about_dup :
  forall ls x stdin stdout,
    iter (dup, state[ls, x, zeroes, stdin, stdout])
         (END, state[Cons x ls, x, zeroes, stdin, stdout]).
Proof.
  unfold dup.
  intros.
  apply (iter_trans _ (> > [< < + > > -END]<END,
                       state[ls, 0, Cons x (Cons x zeroes), stdin, stdout])).
  rewrite plus_n_O at 2.
  rewrite plus_n_O at 3.
  apply (iter_trans _ ([> + > + < < - END] > > [< < + > > -END]<END,
                       state[ls, x, Cons 0 (Cons 0 zeroes), stdin, stdout])).
  bf_step.

  apply about_dup_lemma1.

  do 2 bf_step.
  rewrite (plus_n_O x) at 4.
  simpl.
  apply (iter_trans _ (< END,
                       state[Cons x (Cons (x+0) ls), 0, zeroes, stdin, stdout])).
  apply about_dup_lemma2.

  repeat bf_step.
  simpl.
  rewrite <- plus_n_O.
  bf_step.
Qed.

Definition reset := [-END]END.

Theorem about_reset : forall ls curr rs stdin stdout,
                               iter (reset, state[ls, curr, rs, stdin, stdout])
                                    (END, state[ls, 0, rs, stdin, stdout]).
Proof.
  unfold reset.
  intros.
  induction curr.
  repeat bf_step.

  repeat bf_step.
  exact IHcurr.
Qed.

Definition mult :=
  (* [...;x1][x2][] Move x1 *)
  <[> > + < < -END]> >
  (* [...;0;x2][x1][] *)
  [<
   (* [...;i*x2][x2][x1-i] Add and copy x2 *)
   [< + > > > + < < -END]
   (* [...;(i+1)*x2][0][x1-i;x2] Move to x2 *)
   > >
   (* [...;(i+1)*x2;0;x1-i][x2][] Move back x2 *)
   [< < + > > -END]<
   (* [...;(i+1)*x2;x2][x1-i][] Decrement loop counter *)
   -END
  (* [...;(i+1)*x2;x2][x1-(i+1)][] *)
  ]<
  (* [...;x1*x2][x2][] Cleanup *)
  reset;
  <
  (* [...][x1*x2][] *)
  END.

Example mult_example1 :
  forall stdin stdout,
    iter (mult, state[Cons 2 zeroes, 3, zeroes, stdin, stdout])
         (END, state[zeroes, 6, zeroes, stdin, stdout]).
Proof.
  unfold mult.
  intros.
  repeat bf_step.
Qed.

Example mult_example2 :
  forall stdin stdout,
    iter (mult, state[Cons 0 zeroes, 3, zeroes, stdin, stdout])
         (END, state[zeroes, 0, zeroes, stdin, stdout]).
Proof.
  unfold mult.
  intros.
  repeat bf_step.
Qed.

Example mult_example3 :
  forall stdin stdout,
    iter (mult, state[Cons 2 zeroes, 0, zeroes, stdin, stdout])
         (END, state[zeroes, 0, zeroes, stdin, stdout]).
Proof.
  unfold mult.
  intros.
  repeat bf_step.
Qed.

Theorem about_sequence :
  forall c c' s s' s'',
    iter (c, s)
         (END, s') ->
    iter (c', s')
         (END, s'') ->
    iter (c;c', s)
         (END, s'').
Proof.
  induction c;
  try (
      intros;
      simpl sequence;
      inversion H; subst;
      inversion H1; subst;
      try discriminate H5;

      inversion H1; subst;
      match goal with
        | [ H1 : step_rel ?C (?C', ?S) |- ?P ] =>
          apply (iter_step _ (c;c', S));
        [constructor |
         apply (IHc c' S s'); assumption]
      end).
  intros.
  destruct s as [? []].
  bf_step.
  apply (IHc2 _ _ s').
  inversion H; inversion H1; subst.
  discriminate H7.

  simpl in H1, H2.
  assumption.
  assumption.

  bf_step.
  admit.
  intros.
  simpl sequence.
  inversion H; subst.
  assert ((c', s) ≡ (c', s')) as Hequiv.
  bf_reflexivity.
  inversion H1; assumption.
  apply (iter_injective' (c', s') (c', s) (END, s'')).
  assumption.
  apply EqBf_sym; assumption.

  inversion H1.
Qed.

(* This proof is a total mess! *)
Theorem about_mult :
  forall ls x1 x2 stdin stdout,
    iter (mult, state[Cons x1 ls, x2, zeroes, stdin, stdout])
         (END, state[ls, x1 * x2, zeroes, stdin, stdout]).
Proof.
  unfold mult, reset.
  intros.
  repeat bf_step; simpl.
  generalize dependent x1; generalize dependent x2.
  assert
    (forall x1 x2 k c,
       iter ([> > + < < -END]c, state[ls, x1, Cons x2 (Cons k zeroes), stdin, stdout])
            (c, state[ls, 0, Cons x2 (Cons (x1+k) zeroes), stdin, stdout]))
    as Hmv2.
  induction x1; intros.
  repeat bf_step.
  repeat bf_step; simpl.
  rewrite plus_n_Sm.
  apply IHx1.

  intros.
  apply (iter_trans _ (> > [<
                            [< + > > > + < < -END]> >
                            [< < + > > -END]
                            < -END]
                             < [-END]
                             <END,
                       state[ls, 0, Cons x2 (Cons (x1+0) zeroes), stdin, stdout])).
  apply (iter_trans _ ([> > + < < -END]
                       > > [<
                            [< + > > > + < < -END]> >
                            [< < + > > -END]
                            < -END]
                       < [-END]
                       <END,
                       state[ls, x1, Cons x2 (Cons 0 zeroes), stdin, stdout])).
  bf_step.
  apply Hmv2.
  clear Hmv2.
  rewrite <- plus_n_O.

  do 2 bf_step; simpl.
  generalize dependent x1; generalize dependent x2.
  assert
    (forall x1 x2 k c,
       iter ([<
              [< + > > > + < < -END]
                > >
                [< < + > > -END]
                  < -END]c,
             state[Cons x2 (Cons k ls), x1, zeroes, stdin, stdout])
            (c, state[Cons x2 (Cons (x1 * x2 + k) ls), 0, zeroes, stdin, stdout]))
    as H.
  induction x1.
  intros.
  repeat bf_step.

  intros; bf_step.
  assert
    (forall x1 x2 k i c,
       iter (< [< + > > > + < < -END]> >[< < + > > -END]< -c,
             state[Cons x2 (Cons (i*x2+k) ls), S x1, zeroes, stdin, stdout])
            (c,
             state[Cons x2 (Cons (S i*x2+k) ls), x1, zeroes, stdin, stdout]))
    as Hstep.

  intros.
  bf_step; simpl.
  assert
    (forall x1 x2 k k' c,
       iter ([< + > > > + < < -END]c,
             state[Cons (k) ls, x2, Cons x1 (Cons k' zeroes), stdin, stdout])
            (c, state[Cons (x2+k) ls, 0, Cons x1 (Cons (x2+k') zeroes), stdin, stdout]))
    as Hsomething.
  intros x x'.
  induction x'.
  intros.
  repeat bf_step.

  intros.
  repeat bf_step; simpl.
  replace (S (x' + k')) with (x' + S k') by auto with arith.
  replace (S (x' + k1)) with (x' + S k1) by auto with arith.
  apply IHx'.

  apply (iter_trans _
                    (> >[< < + > > -END]< - c0,
                     state[Cons (x3+(i*x3+k0)) ls, 0,
                           Cons (S x0) (Cons (x3+0) zeroes), stdin, stdout])).
  apply (iter_trans _
                    ([< + > > > + < < - END]> > [< < + > > - END]< - c0,
                     state[Cons (i * x3 + k0) ls, x3,
                           Cons (S x0) (Cons 0 zeroes), stdin, stdout])).
  bf_step.
  apply (Hsomething (S x0) x3 (i*x3+k0) 0).
  clear Hsomething.
  do 2 bf_step; simpl.
  apply (iter_trans
           _ (< - c0,
              state[Cons (S x0) (Cons x3 (Cons (x3+(i*x3+k0)) ls)),
                    0, zeroes, stdin, stdout])).
  rewrite plus_0_r.
  assert
    (forall k k',
       iter
         ([< < + > > - END]< - c0,
          state[Cons (S x0) (Cons k (Cons (k' + (i * k' + k0)) ls)),
                x3, zeroes, stdin, stdout])
         (< - c0,
          state[Cons (S x0) (Cons (x3+k) (Cons (k' + (i * k' + k0)) ls)),
                0, zeroes, stdin, stdout]))
  as Hind.
  induction x3.
  intros.
  repeat bf_step.

  intros.
  repeat bf_step; simpl.
  replace (S (x3 + k1)) with (x3 + S k1) by auto with arith.
  apply (IHx3 (S k1)).
  rewrite <- (plus_0_r x3) at 4.
  apply Hind.

  repeat bf_step; simpl.
  replace (x3 + (i * x3 + k0)) with (x3 + i * x3 + k0) by auto with arith.
  repeat bf_step.

  apply (iter_trans
           _
           ([< [< + > > > + < < - END]> > [< < + > > - END]< - END]c,
            state[Cons x2 (Cons (x2+k) ls), x1, zeroes, stdin, stdout])).
  rewrite <- (plus_0_l k) at 1.
  rewrite <- (mult_0_l x2) at 1.
  rewrite <- (mult_1_l x2) at 4.
  apply (Hstep x1 x2 k 0).
  replace (x2 + x1*x2 + k) with (x1*x2+(x2+k)).
  apply (IHx1 x2 (x2+k)).
  rewrite (plus_comm x2 (x1*x2)).
  rewrite plus_assoc.
  reflexivity.

  intros.
  apply (iter_trans
           _
           (<[-END]<END, state[Cons x2 (Cons (x1*x2) ls), 0, zeroes, stdin, stdout])).
  rewrite <- (plus_0_r (x1*x2)).
  apply (H x1 x2 0).

  repeat bf_step; simpl.

  assert
    (forall ls x rs stdin stdout c,
        iter
          ([-END]c, state[ls, x, rs, stdin, stdout])
          (c, state[ls, 0, rs, stdin, stdout]))
    as Hreset.
  intros; induction x; repeat bf_step; apply IHx.
  apply (iter_trans _ ([-END]< END, state[Cons (x1*x2) ls, x2, zeroes, stdin, stdout])).
  bf_step.
  apply (iter_trans _ (< END, state[Cons (x1*x2) ls, 0, zeroes, stdin, stdout])).
  apply (Hreset (Cons (x1*x2) ls) x2 zeroes stdin stdout (< END)).
  repeat bf_step.
Qed.

Corollary add_two_numbers :
  forall n m stdin,
    iter (push n; (push m; add), init stdin)
         (END, state[zeroes, m+n, zeroes, stdin, nil]).
Proof.
  unfold init.
  intros.
  apply (about_sequence
           (push n) (push m; add) _
           state[zeroes, n, zeroes, stdin, nil]).
  apply (iter_trans _
                    (END, state[Cons 0 zeroes, n, zeroes, stdin, nil])).
  apply about_push.
  bf_step.

  apply (about_sequence
           (push m) add _
           state[Cons n zeroes, m, zeroes, stdin, nil]).
  apply about_push.

  apply about_add.
Qed.


(* delta-reduction *)
Require Import ZArith.
Open Scope Z_scope.

Definition Zsqr (z:Z) : Z := z*z.
Definition myFunc (f:Z->Z)(z:Z) : Z := f(f z).

(* cbv call by value strategy *)
Eval cbv delta [myFunc Zsqr] in (myFunc Zsqr).  (* looks like unfold *)

Eval cbv delta [myFunc] in (myFunc Zsqr).

Eval cbv beta delta [myFunc Zsqr] in (myFunc Zsqr).

Eval compute in (myFunc Zsqr 3).


Set Implicit Arguments.
Unset Strict Implicit.

Require Import SMTC.Integers.
Require Import Coq.Setoids.Setoid.
Require Import ZArith.
Require Import Arith.
Require Import LibTactics.
Require Import IntAuto.
(*Require Import bits_map.*)

Module _mathsolver.

Fixpoint _iter {T:Type} (f:T->T) (base : T) (n: nat) : T :=
  match n with
      | O => base
      | S n' => _iter f (f base) n'
 end.
Module Type has_le.
  Parameter A: Type.
  Parameter le : A->A->Prop.

  Axiom le_refl : forall x:A, le x x.
  Axiom le_antisymm : forall a b:A, le a b -> le b a -> a=b.
  Axiom le_trans : forall a b c:A, le a b -> le b c -> le a c.
End has_le.

Module Type has_next (LE: has_le).
  Import LE.
  Parameter next : A->A.
  Axiom next_is_smallest : forall (x n:A), le x n <-> n =  x \/ le (next x) n.
End has_next.

Module Type has_dist (Import LE: has_le) (Import HN:has_next LE).
  Parameter dist : A->A->nat.
  Axiom dist_a : forall a b,le a b-> _iter next a (dist a b) = b.
End has_dist.

Module Range (Import LE: has_le) (Import HN : has_next LE) (Import HD: has_dist LE HN).
  Definition range (b:A)(l:nat)(x:A) := le b x /\ le x (_iter next b l).

  Lemma x_le_next: forall x :A , le x (next x).
    intros.
    rewrite next_is_smallest.
    right.
    apply le_refl.
  Qed.

  Lemma x_le_iter_next : forall (x :A) (n:nat), le x (_iter next x n).
    intros.
    generalize x; clear x.
    induction n.
    simpl.
    apply le_refl.
    simpl.
    intros.
    eapply (@le_trans _  (next x)).
    apply x_le_next.
    apply IHn.
  Qed.

  Lemma range_l_r: forall (l r x:A) , le l r -> (le l x /\ le x r <-> range l (dist l r) x).
    intros.
    split;
    intro;
    unfold range in *;
    rewrite dist_a in *;auto.
  Qed.

  Lemma range_split_first' : forall (b:A) (l:nat) (x:A), x=b \/ range (next b) l x -> range b (S l) x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    elim H; intros.
    unfold range.
    simpl.
    rewrite H0.
    split.
    apply le_refl.

    apply x_le_next.

    unfold range.
    unfold range in H0.
    unfold _iter in H0.
    unfold _iter.
    elim H0; intros.
    set (@le_antisymm x (next b) H2 H1 ).
    rewrite e.
    split.
    apply x_le_next.
    apply le_refl.

    intros.

    elim H; intros.
    rewrite H0; split; intros.
    apply le_refl.
    simpl.

    eapply (@le_trans _  (next (next b))).
    eapply (@le_trans _ (next b)).
    apply (x_le_next).
    apply x_le_next.
    apply x_le_iter_next.

    unfold range in *.
    elim H0; intros.
    split.
    eapply le_trans.
    Focus 2.
    exact H1.
    apply x_le_next.
    simpl.
    simpl in H2.
    exact H2.
  Qed.

  Lemma range_split_first'' : forall (b:A) (l:nat) (x:A), range b (S l) x -> x=b \/ range (next b) l x.
    intros.
    set (next_is_smallest b x).
    elim i; intros o o'.
    unfold range in H.
    inversion H.
    set (o H0).
    elim o0; intros.
    left; auto.
    right; unfold range.
    split; auto.
  Qed.

  Lemma range_split_first : forall (b:A) (l:nat) (x:A), range b (S l) x <-> x=b \/ range (next b) l x.
    split.
    apply range_split_first''.
    apply range_split_first'.
  Qed.

  Lemma range_eq : forall (l x:A), range l O x <-> x=l.
    split;intros.
    unfold range in H.
    elim H; intros.
    apply le_antisymm; auto.
    unfold range; rewrite H; split;apply le_refl.
  Qed.

  (* good *)
  Fixpoint gen_prop (b:A) (len:nat) (x:A) {struct len} :=
    match len with
      | O => x=b
      | S n => x = b \/ gen_prop (next b) n x
    end.

  (* bad *)
  Fixpoint gen_prop' (b:A) (len:nat) (x:A) {struct len} :=
    match len with
      | O => x=b
      | S n => gen_prop' b n x \/ x= _iter next b len
    end.

  Lemma range_fin_elem: forall b l x, range b l x <-> gen_prop b l x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros; split; simpl;
    apply range_eq.

    intros; split; simpl; intros.
    apply range_split_first in H.
    elim H; intros.
    left; auto.
    right.
    apply IHl.
    auto.

    apply range_split_first.
    elim H; intros.
    left; auto.
    right; apply IHl.
    auto.
  Qed.
  Lemma range_l_r_fin_elem: forall (l r x:A) , le l r -> (le l x /\ le x r <-> gen_prop l (dist l r) x).
    intros.
    split.
    intro.
    rewrite range_l_r in H0.
    rewrite range_fin_elem in H0.
    auto.
    auto.
    intro.
    rewrite range_l_r; auto.
    rewrite range_fin_elem; auto.
  Qed.

  Lemma range_split_last'' : forall (b:A) (l:nat) (x:A), range b (S l) x -> range b l x \/ x= _iter next b (S l).
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    simpl.
    rewrite range_fin_elem in *.
    simpl in *.
    auto.
    intros.

    apply range_split_first in H.
    elim H; intros.
    left; rewrite H0.
    unfold range.
    split; auto.
    apply le_refl.
    apply x_le_iter_next.
    apply IHl in H0.
    elim H0; intros.
    left.

    unfold range.
    unfold range in H1.
    elim H1; intros.
    split.
    eapply le_trans.
    Focus 2.
    exact H2.
    apply x_le_next.
    simpl.
    exact H3.

    right.
    auto.
  Qed.

  Lemma iter_n_lt_lt: forall n b, le (_iter next b n) (_iter next b (S n)).
    intro.
    induction n.
    intros.
    simpl.
    apply x_le_next.

    intros.
    assert (forall k, _iter next b (S k) = _iter next (next b) k).
    auto.
    rewrite H.
    rewrite H.
    apply IHn.
  Qed.

  Lemma range_split_last' : forall (b:A) (l:nat) (x:A), range b l x \/ x = _iter next b (S l) -> range b (S l) x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    rewrite range_fin_elem in *.
    simpl in *.
    auto.

    intros.
    elim H; intros.
    unfold range in H0.
    unfold range.
    elim H0; intros; split; auto.
    eapply le_trans.
    exact H2.

    apply iter_n_lt_lt.
    unfold range.
    split.
    rewrite H0.
    apply x_le_iter_next.
    rewrite H0.
    apply le_refl.
  Qed.

  Lemma range_split_last : forall (b:A) (l:nat) (x:A), range b l x \/ x = _iter next b (S l) <-> range b (S l) x.
    intros.
    split.
    apply range_split_last'.
    apply range_split_last''.
  Qed.

  Lemma range_fin_elem2' : forall b len x, range b len x -> gen_prop' b len x.
    intros b l.
    generalize b; clear b.
    induction l.
    intros.
    simpl in *.
    apply range_eq.
    auto.

    intros.
    simpl.
    rewrite <- range_split_last in H.
    elim H; intros.
    left.
    apply IHl.
    auto.
    right.
    simpl in H0; auto.
  Qed.

  Lemma range_fin_elem2'': forall b len x, gen_prop' b len x -> range b len x.
    intros b l.
    generalize b; clear b.
    induction l;intros.
    simpl in H; apply range_eq.
    auto.

    rewrite<- range_split_last.
    simpl in H.
    elim H; intros.
    left; apply IHl; auto.
    right; simpl; auto.
  Qed.

  Lemma range_fin_elem2 : forall b len x, gen_prop' b len x <-> range b len x.
    intros.
    split.
    apply range_fin_elem2''.
    apply range_fin_elem2'.
  Qed.
End Range.

(* Z has le next and dist *)
Module Z_has_le <: has_le.
  Definition A := Z.
  Definition le := Zle.

  Definition le_refl:=Z.le_refl.
  Definition le_antisymm :=Z.le_antisymm.
  Definition le_trans := Z.le_trans.
End Z_has_le.

Module Z_has_next <: has_next Z_has_le.
  Definition next := fun x:Z => (1+ x)%Z.
  Lemma next_is_smallest: forall (x a:Z), Zle x a <-> a = x \/ Zle (next x) a.
    intros.
    split; intros.
    apply Z.le_lteq in H.
    elim H; intros.
    right.
    unfold next.
    omega.
    left ; auto.

    rewrite Z.le_lteq.
    elim H; intros.
    right; auto.
    left; unfold next in H0; omega.
  Qed.
End Z_has_next.

Module Z_has_dist <: has_dist Z_has_le Z_has_next.
  Import Z_has_le.
  Import Z_has_next.
  Definition dist := fun a b:Z => Z.to_nat (b-a).
    Lemma dist_a': forall n a, _iter next a n = (a+ Z.of_nat n)%Z.
       intro.
       induction n.
       intros.
       simpl.
       omega.

       intros.
       rewrite Nat2Z.inj_succ.
       simpl.
       rewrite IHn.
       unfold next.
       omega.
    Qed.

  Lemma dist_a : forall a b, le a b -> _iter next a (dist a b)  =b.
    intros a b.
    intro.
    assert (b = a + Z.of_nat (dist a b))%Z.
    unfold dist.
    rewrite Z2Nat.id.
    omega.
    unfold le in H; omega.
    rewrite H0 at 2.
    apply dist_a'.
  Qed.
End Z_has_dist.

(* nat has le next and dist *)

Module nat_has_le <: has_le.
  Definition A := nat.
  Definition le := le.

  Definition le_refl:=le_refl.
  Definition le_antisymm :=le_antisym.
  Definition le_trans := le_trans.
End nat_has_le.

Module nat_has_next <: has_next nat_has_le.
  Definition next := fun x => (S x).
  Lemma next_is_smallest: forall (x a:nat), le x a <-> a = x \/ le (next x) a.
    intros.
    split; intros.
    apply le_lt_or_eq_iff in H.
    elim H; intros.
    right.
    unfold next.
    omega.
    left ; auto.
    rewrite le_lt_or_eq_iff.
    elim H; intros.
    right; auto.
    left; unfold next in H0; omega.
  Qed.
End nat_has_next.

Module nat_has_dist <: has_dist nat_has_le nat_has_next.
  Import nat_has_le.
  Import nat_has_next.
  Definition dist := fun a b: nat => (b-a)%nat.
    Lemma dist_a': forall n a, _iter next a n = (a+n)%nat.
       intro.
       induction n.
       intros.
       simpl.
       omega.

       intros.
       simpl.
       rewrite IHn.
       unfold next.
       omega.
    Qed.

  Lemma dist_a : forall a b, le a b -> _iter next a (dist a b)  =b.
    intros a b.
    intro.
    assert (b = a + (dist a b))%nat.
    unfold dist.
    unfold le in H.
    omega.
    rewrite H0 at 2.
    apply dist_a'.
  Qed.
End nat_has_dist.

Module Z_range := Range Z_has_le Z_has_next Z_has_dist.

Module nat_range := Range nat_has_le nat_has_next nat_has_dist.

Ltac nat_range_unfold_all H:=try unfold nat_range.gen_prop in H;try unfold nat_has_next.next in H;try unfold nat_has_dist.dist in H;try unfold nat_has_le.A in H.

Ltac Z_range_unfold_all H:=try unfold Z_range.gen_prop in H;try unfold Z_has_next.next in H;try unfold Z_has_dist.dist in H;try unfold Z_has_le.A in H.

Ltac stdrange_fin_elem :=
  repeat progress
  match goal with
      | H : ( _ <= ?a (?b _) <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta -[a b] iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= ?a _ _ <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= ?a _ <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= _ <= _)%nat |- _ => apply nat_range.range_l_r_fin_elem in H;[cbv beta delta iota in H| unfold nat_has_le.le; omega]
      | H : ( _ <= ?a (?b _) <= _)%Z |- _ => apply Z_range.range_l_r_fin_elem in H;[cbv beta delta -[a b] iota in H| unfold Z_has_le.le; omega]
      | H : ( _ <= ?a _ _ <= _)%Z |- _ => apply Z_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold Z_has_le.le; omega]
      | H : ( _ <= ?a _ <= _)%Z |- _ => apply Z_range.range_l_r_fin_elem in H;[cbv beta delta -[a] iota in H| unfold Z_has_le.le; omega]
      | H : ( _ <= _ <= _ )%Z   |- _ => apply Z_range.range_l_r_fin_elem  in H;[cbv beta delta iota in H| unfold Z_has_le.le; omega]
      | _ => fail
  end.

(* range split part end *)

Open Scope nat_scope.
  Lemma nat_lt2stdrange : forall x b:nat, x<b -> 0<=x<=(pred b).
    intros;set (le_0_n x); split; auto.
    omega.
  Qed.

  Lemma nat_le2stdrange : forall x b:nat,  x<=b -> 0<=x<=b.
    intros; set (le_0_n x);split; auto.
  Qed.

  Lemma nat_gt2stdrange : forall x b:nat, b>x -> 0<=x<=(pred b).
    intros; set (le_0_n x); split; auto.
    omega.
  Qed.
  Lemma nat_ge2stdrange: forall x b, b>=x -> 0<=x<=b.
    intros; set (le_0_n x); split; auto.
  Qed.
Close Scope nat_scope.

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

Open Scope Z_scope.
  Lemma unsigned_lt2stdrange : forall x b, Int.unsigned x< b -> 0<=Int.unsigned x <= (Z.pred b).
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma unsigned_le2stdrange : forall x b, Int.unsigned x<=b -> 0<=Int.unsigned x<=b.
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma unsigned_gt2stdrange : forall x b,  b > Int.unsigned x -> 0<=Int.unsigned x <= (Z.pred b).
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma unsigned_ge2stdrange : forall x b, b >= Int.unsigned x -> 0<=Int.unsigned x<=b.
    intros;split;[set (Int.unsigned_range x); tauto| omega].
  Qed.

  Lemma repr_unsigned : forall x n, Int.unsigned x = n -> x= Int.repr n.
    intros.
    rewrite <- H.
    rewrite Int.repr_unsigned.
    reflexivity.
  Qed.

  (* TODO: change this function *)
  Ltac pre' :=
    match goal with
       | H : (?x <  ?b)%nat |- _                => apply nat_lt2stdrange in H
       | H : (?x <= ?b)%nat |- _                => apply nat_le2stdrange in H
       | H : (?b >  ?x)%nat |- _                => apply nat_gt2stdrange in H
       | H : (?b >= ?x)%nat |- _                => apply nat_ge2stdrange in H
       | H : (Int.unsigned ?x <  ?b)     |- _   => apply unsigned_lt2stdrange in H
       | H : (Int.unsigned ?x <= ?b)     |- _   => apply unsigned_le2stdrange in H
       | H : (?b >  Int.unsigned ?x )    |- _   => apply unsigned_gt2stdrange in H
       | H : (?b >= Int.unsigned ?x)     |- _   => apply unsigned_ge2stdrange in H
       | H : (?a < ?x < ?b)%nat |- _            => let H' := fresh in rename H into H'; assert ( (S a) <= x <= (pred b))%nat as H by omega; clear H'
       | H : (?a <= ?x < ?b)%nat |- _           => let H' := fresh in rename H into H'; assert ( (a) <= x <= (pred b))%nat as H by omega; clear H'
       | H : (?a < ?x <= ?b)%nat |- _           => let H' := fresh in rename H into H'; assert ( (S a) <= x <= ( b))%nat as H by omega; clear H'
       | H : (?a < ?x < ?b) |- _                => let H' := fresh in rename H into H'; assert ( (1+ a) <= x <= (Z.pred b)) as H by omega; clear H'
       | H : (?a <= ?x < ?b) |- _               => let H' := fresh in rename H into H'; assert ( (a) <= x <= (Z.pred b)) as H by omega; clear H'
       | H : (?a < ?x <= ?b) |- _               => let H' := fresh in rename H into H'; assert ( (1+ a) <= x <= ( b)) as H by omega; clear H'
    end.

  Ltac pre := repeat pre';repeat ((* handle even not a real range, 1<=x<=0 for example*)try omega; timeout 8 stdrange_fin_elem).
  Ltac pre_noto := repeat pre';repeat ((* handle even not a real range, 1<=x<=0 for example*)try omega; stdrange_fin_elem).

  (* do NOT use this *)
  (* use a tactic as a param in another tactic is VERY slow*)
  Ltac brute_force tac:=
    match goal with
        | H : _ \/ _ |- _ => destruct H; brute_force tac
        | _               => tac
    end.

  Lemma sample'' : forall n , (0< n<63)%nat ->True.
    intros.
    pre.
    auto.
  Qed.

  Lemma sample0: forall n m :int32,  Int.unsigned m < 64 -> 64 > Int.unsigned n ->  True.
    intros.
    pre.
    auto.
  Qed.

  Lemma sample1: forall n:nat, (n<25)%nat-> True.
    intros.
    pre.
    auto.
  Qed.

  Lemma sample2: forall n:nat, (25>n)%nat-> True.
    intros.
    pre.
    auto.
  Qed.

  Ltac math_solver_pre :=
    match goal with
        | H : Int.unsigned _ = _ |- _ => apply repr_unsigned in H
        | _  => idtac
    end.

  (* can use compute -[Int.unsigned Int.mone] instead *)
  Ltac munfold :=try unfold Int.shru; try unfold Int.shl; try unfold Int.not; try unfold Z.shiftr; try unfold Int.xor; try unfold Int.and; try unfold Z.to_nat; try unfold Pos.to_nat; try unfold Int.or; try unfold Z.lor; try unfold Int.divu; try unfold Int.add; try unfold Int.mul; try unfold Int.sub; try unfold Int.ltu; try unfold Int.zero; try unfold Int.one; try unfold Int.eq.

  Ltac mycompute := compute -[Int.unsigned].

(*
Lemma div_in_intrange: forall x a mx:Z, (0<=x <=mx -> a>0 -> 0<= Z.div x a <=mx)%Z.
  intros.
  split.
  ht.revs.
  apply Z_div_ge0.
  omega.
  omega.
  apply Z.div_le_upper_bound.
  omega.
  elim H; intros.
  eapply Zle_trans.
  exact H2.
  ht.revs.
  apply a_mult_b_ge_b; omega.
Qed.
  Ltac solve_int_range :=
match goal with
    | i : int32 |- _ => let xval := fresh in let xrange := fresh in destruct i as [xval xrange]; unfold Int.modulus, two_power_nat, shift_nat in xrange; simpl in xrange; simpl in *;  solve_int_range
    | _ => subst; try rewrite max_unsigned_val; solve [ omega | apply div_in_intrange; omega ]
end.
  Ltac rangesolver :=try solve_int_range; repeat (rewrite Int.unsigned_repr; try solve_int_range).
  Ltac ur_rewriter := rewrite Int.unsigned_repr; [idtac| rangesolver].
  Ltac ur_rewriter_in H := rewrite Int.unsigned_repr in H; [idtac| rangesolver].
 *)
  Ltac trivial_ur_rewriter := rewrite Int.unsigned_repr;[idtac| rewrite max_unsigned_val; omega].

  Ltac subst_all := subst.

(* not so basic *)
  Ltac basic_solver := match goal with
| H : Int.unsigned ?a = ?b |- _  => rewrite H in *; apply repr_unsigned in H; basic_solver
| _  => subst_all; simpl; repeat trivial_ur_rewriter; simpl; solve [auto| omega |  timeout 2 mycompute; intros; try split; tryfalse; try omega; auto]
end.
  Ltac basic_solver_noto := match goal with
| H : Int.unsigned ?a = ?b |- _  => rewrite H in *; apply repr_unsigned in H; basic_solver
| _  => subst_all; simpl; repeat trivial_ur_rewriter; simpl; solve [auto| omega |  mycompute; intros; try split; tryfalse; try omega; auto]
end.

  Ltac bf_basic_solver :=
    repeat progress
           match goal with
             | H : _ \/ _ |- _  => destruct H;
                                  [match goal with
                                     |  H' : _\/_ |- _ => destruct H';
                                                         [match goal with
                                                            |  H'' : _\/_ |- _ => destruct H''; [basic_solver | idtac]
                                                            |  _ => basic_solver
                                                          end | idtac ]
                                     |  _ => basic_solver
                                   end | idtac ]
             | _ => basic_solver
           end.

  Ltac bf_basic_solver_noto :=
    repeat progress
           match goal with
             | H : _ \/ _ |- _  => destruct H;
                                  [match goal with
                                     |  H' : _\/_ |- _ => destruct H';
                                                         [match goal with
                                                            |  H'' : _\/_ |- _ => destruct H''; [basic_solver_noto | idtac]
                                                            |  _ => basic_solver_noto
                                                          end | idtac ]
                                     |  _ => basic_solver_noto
                                   end | idtac ]
             | _ => basic_solver_noto
           end.

  Ltac basic_solver_safe := match goal with
| H : Int.unsigned ?a = ?b |- _  => rewrite H; apply repr_unsigned in H; basic_solver_safe
| _  => subst_all; simpl;  split; try omega
end.

Ltac bf1_basic_solver :=
   match goal with
     | H : _ \/ _ |- _  => solve[clear -H; repeat (destruct H as [H | H] ;[basic_solver_safe| idtac] ) ; basic_solver_safe]
   end.

Ltac clear_useless_or :=
  match goal with
      | H : _ ?a = _ \/ _ |- _ => clear dependent a
      | H : ?a = _ \/ _   |- _ => clear dependent a
end.

Ltac clear_all_useless_or := repeat clear_useless_or.

Ltac mrewrite := repeat rewrite unsigned_mone_val; repeat rewrite Int.unsigned_repr; try rewrite max_unsigned_val; [idtac|solve [clear; omega |  clear_all_useless_or;  bf_basic_solver] .. ].
Ltac mrewrite_noto := repeat rewrite unsigned_mone_val; repeat rewrite Int.unsigned_repr; try rewrite max_unsigned_val; [idtac|solve [clear; omega |  clear_all_useless_or;  bf_basic_solver_noto] .. ].

  Ltac new_mathsolver:= munfold; pre; mrewrite; bf_basic_solver.
  Ltac new_mathsolver_noto := munfold; pre_noto; mrewrite_noto; bf_basic_solver_noto.
  (* old version *)
  Ltac math_rewrite :=
    repeat progress (
             try rewrite Int.unsigned_repr in *;
             try rewrite max_unsigned_val in *;
             try omega ;
             try rewrite unsigned_mone_val in *;
             try omega; auto).

  Ltac math_solver:=
    math_solver_pre;
    subst;
    try simpl in *;
    try unfold Int.shru in *;
    try unfold Int.shl in *;
    try unfold Int.not in *;
    try unfold Z.shiftr in *;
    try unfold Int.xor in *;
    try unfold Int.and in *;
    try unfold Z.to_nat in *;
    try unfold Pos.to_nat in *;
    try unfold Int.or in *;
    try unfold Z.lor in *;
    try unfold Int.divu in *;
    try unfold Int.add in *;
    try unfold Int.mul in *;
    try unfold Int.sub in *;
    try unfold Int.ltu in *;
    try unfold Int.zero in *;
    try unfold Int.one in *;
    try unfold Int.eq in *;
    match goal with
      | H : ?f  _  =  _ |- _ => simpl f in H;  inverts H
      | _ => idtac
    end;
    math_rewrite;
    try simpl in *;
    math_rewrite;
    intuition tryfalse;
    try (simpl; omega).

  Ltac mathsolver' :=
    repeat progress
           match goal with
             | H : False |- _ => inversion H
             | H : _ \/ _ |- _  => destruct H;
                                  [match goal with
                                     |  H' : _\/_ |- _ => destruct H';
                                                         [match goal with
                                                            |  H'' : _\/_ |- _ => destruct H''; [math_solver | idtac]
                                                            |  _ => math_solver
                                                          end | idtac ]
                                     |  _ => math_solver
                                   end | idtac ]
             | _ => math_solver
           end.

  Ltac mathsolver:= pre; mathsolver'.

End _mathsolver.
(*
Require Import memory. (* for Vint32 *)
Require Import OSTCBInvDef. (* for OSUnMapVallist *)
Require Import BaseAsrtDef. (* for nth_val' *)

Module _mathsolver_ext.
  Close Scope nat_scope.
  Open Scope Z_scope.
  Definition deref_Vint32_unsafe (x:val): int32 :=
    match x with
        | Vint32 x => x
        | _ => (Int.repr 0)
    end.

  Lemma OSUnMapVallist_safe_deVint32 : forall z y, 0<=z<=255 -> nth_val' (Z.to_nat z) OSUnMapVallist = Vint32 y -> y = deref_Vint32_unsafe ( nth_val' (Z.to_nat z) OSUnMapVallist).
Proof.
  intros.
  _mathsolver.pre.
  repeat (destruct H; [rewrite H in *; simpl in H0; inversion H0; auto| idtac]).
  rewrite H in *; simpl in H0; inversion H0; auto.
Qed.

  Lemma OSMapVallist_safe_deVint32 : forall z y, 0<=z<=7 -> nth_val' (Z.to_nat z) OSMapVallist = Vint32 y -> y = deref_Vint32_unsafe ( nth_val' (Z.to_nat z) OSMapVallist).
    intros.
    _mathsolver.pre.
    repeat (destruct H; [rewrite H in *; simpl in H0; inversion H0; auto| idtac]).
    rewrite H in *; simpl in H0; inversion H0; auto.
  Qed.

  Ltac deref_vint32_for_array := match goal with
                                 | H : nth_val' (Z.to_nat (Int.unsigned ?a) ) OSUnMapVallist = Vint32 _ |- _=> apply OSUnMapVallist_safe_deVint32 in H;[unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H |set (@Int.unsigned_range_2 a); try omega]
                                 | H : nth_val' (Z.to_nat (Int.unsigned ?a) ) OSMapVallist = Vint32 _ |- _ => apply OSMapVallist_safe_deVint32 in H; [unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H | set (@Int.unsigned_range_2 a);  try omega]
                                 | H : nth_val' (Z.to_nat _ ) OSUnMapVallist = Vint32 _ |- _=> apply OSUnMapVallist_safe_deVint32 in H;[unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H | try omega]
                                 | H : nth_val' (Z.to_nat _ ) OSMapVallist = Vint32 _ |- _ => apply OSMapVallist_safe_deVint32 in H; [unfold deref_Vint32_unsafe in H; try rewrite H in *; clear H | try omega]
                                 end.
End _mathsolver_ext.
*)

Ltac mauto := (*repeat _mathsolver_ext.deref_vint32_for_array; *)_mathsolver.new_mathsolver.
Ltac mauto_noto := (*repeat _mathsolver_ext.deref_vint32_for_array;*) _mathsolver.new_mathsolver_noto.
Ltac mauto_old := _mathsolver.mathsolver.
Ltac mauto_dbg := _mathsolver.pre.