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

Title: Auxiliary.v
Authors: Jeremy Avigad, Chris Kapulkin, Peter LeFanu Lumsdaine
Date: 1 March 2013

This file contains lemmas that are required as background in the
Fibration Categories project, but are not supplied by the HoTT
library.

*******************************************************************************)

Require Import HoTT.

Require Export FunextAxiom.

Open Scope path.
Open Scope equiv.

Monomorphic Definition UU := Type.

Notation pr1 := projT1.
Notation pr2 := projT2.

Arguments pr1 {_ _} _.
Arguments pr2 {_ _} _.

(* TODO (mid): possible improvements now that we’re over the new library.

- increase usage of the [moveL_Pm] family;

- use [apply (concat H)] and [apply (concatR H)], rather than e.g. [path_via' p. apply H.]

- use [whiskerL], [whiskerR] rather than [apply (ap (concat p))] and [apply (ap (fun q => q @ p))].

*)

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

Paths.

*******************************************************************************)

Section Paths.

(* Convenient for the frequent idiom [apply (concat (concat_pp_p))] and variants. *)
Global Arguments concat_pp_p {_ _ _ _ _ _ _ _}.
Global Arguments concat_p_pp {_ _ _ _ _ _ _ _}.

(* The Paulin-Mohring elimination principle for equalities is
very useful, but asymmetric. This is its left-handed counterpart. *)
Definition id_opp_elim {X:Type} (x:X)
  {P:forall (y:X) (p:y=x), Type}
: (P x 1)
  -> forall (y:X) (p:y=x), P y p.
Proof.
  intros P1 y p. destruct p. assumption.
Defined.
(* Note: this proof, while clean, is proof-theoretically overkill — it requires a universe, since inspecting it carefully, it Id-eliminates into a Pi-type with large domain (since P has to be generalized).  With a little more work, it can be proved more economically, using just pure M-L TT. *)

Definition path_space (A : Type) := { x:A & { y:A & x = y }}.

(* Useful mainly for the idiom [apply (concatR (expression))]. *)
Definition concatR {A : Type} {x y z : A}  (q : y = z) (p : x = y)
  := concat p q.

End Paths.

(* A variant of [path_via] that does not attempt to do anything clever. *)
Ltac path_via' mid :=
  apply @concat with (y := mid).

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

Lemmas about paths in types of the form [{a : A & {b : B & C a b}}].

*******************************************************************************)

Section TriplePaths.

Lemma triple_path  {A : Type} {B : Type} (C : A -> B -> Type)
  (u v : {a : A & {b : B & C a b}})
  (p : (pr1 u) = (pr1 v))
  (q : (pr1 (pr2 u)) = (pr1 (pr2 v)))
  (r : (transport (fun x => C x (pr1 (pr2 v))) p
         (transport (C (pr1 u)) q (pr2 (pr2 u))))
       = (pr2 (pr2 v)))
: u = v.
Proof.
  destruct u as [u1 [u2 u3]], v as [v1 [v2 v3]]. simpl in * |- *.
  destruct p; destruct q; destruct r. simpl. exact 1.
Defined.

Lemma pr1_triple_path  {A : Type} {B : Type} (C : A -> B -> Type)
  (u v : {a : A & {b : B & C a b}})
  (p : (pr1 u) = (pr1 v))
  (q : (pr1 (pr2 u)) = (pr1 (pr2 v)))
  (r : (transport (fun x => C x (pr1 (pr2 v))) p
         (transport (C (pr1 u)) q (pr2 (pr2 u))))
       = (pr2 (pr2 v)))
: ap pr1 (triple_path C u v p q r) = p.
Proof.
  destruct u as [u1 [u2 u3]], v as [v1 [v2 v3]]. simpl in * |- *.
  destruct p. destruct q. destruct r. simpl. exact 1.
Defined.

Lemma pr2_triple_path  {A : Type} {B : Type} (C : A -> B -> Type)
  (u v : {a : A & {b : B & C a b}})
  (p : (pr1 u) = (pr1 v))
  (q : (pr1 (pr2 u)) = (pr1 (pr2 v)))
  (r : (transport (fun x => C x (pr1 (pr2 v))) p
         (transport (C (pr1 u)) q (pr2 (pr2 u))))
       = (pr2 (pr2 v)))
: ap (fun xyz => pr1 (pr2 xyz)) (triple_path C u v p q r) = q.
Proof.
  destruct u as [u1 [u2 u3]], v as [v1 [v2 v3]]. simpl in * |- *.
  destruct p. destruct q. destruct r. simpl. exact 1.
Defined.

(* TODO (low): triple_path_pr3.  (The tricky bit is typing the statement.) *)

End TriplePaths.

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

Equivalences.

*******************************************************************************)

(* TODO (low): move this declarations into the section itself, once weird bug is sorted out. *)
Arguments BuildEquiv [A B f] _ : rename.

Section Equivs.

(* TODO (high): move to library. *)
Global Arguments equiv_inv [A B] f {_} x.

(* TODO (low): consider; possibly move to library. *)
Global Arguments equiv_fun [A B] _ _.
Global Arguments equiv_isequiv [A B] e.
Global Arguments isequiv_adjointify [A B f] _ _ _.

(* TODO (med): Unnecessary here; but probably move to library. *)
Global Arguments isequiv_ap [A B] f {_} x y.

(* TODO (high): move to library. *)
Global Arguments isequiv_postcompose {_} A [B C] f {_}.
Global Arguments isequiv_precompose {_} [A B] C f {_}.

(*
TODO (low): also consider/try changing arguments as follows:
Arguments cancelL_isequiv [B C] g {ge} [A] f {fge} : rename.
Arguments cancelR_isequiv [A B] f {fe} [C] g {gfe}.

Also: consider changing the order of their arguments; and *definitely* try making them not instances.
*)

(* Compare to [map_equiv_o_inverse] in old library *)
(* TODO (low): actually, this is an instance of homotopy-naturality, [concat_Ap].  Can it be replaced by that? *)
Lemma ap_inverse_o_equiv {A B : Type} (e : A <~> B)
  {x y : B} (p : x = y)
: ap e (ap (e ^-1) p)
  = (eisretr e x @ p) @ (eisretr e y)^.
Proof.
  destruct p. simpl.
  path_via (eisretr e x @ (eisretr e x)^).
    symmetry. apply concat_pV.
  apply whiskerR, inverse, concat_p1.
Defined.

(* Every type [P] is equivalent to the function type [1 -> P]. *)
Lemma well_pointedness (P : Type) : P <~> (Unit -> P).
Proof.
  exists (fun x _ => x).
  apply (isequiv_adjointify (fun f => f tt)).
  intros f. apply path_forall. intros []. exact 1.
  intros x. exact 1.
Defined.

End Equivs.

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

HLevels.

*******************************************************************************)

Section HLevels.

(* TODO (low): move to HoTT? *)
Record HSet := {
  hset_carrier :> Type;
  ishset_hset : IsHSet hset_carrier }.

End HLevels.

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

Functional Extensionality.

*******************************************************************************)

Section Funext.

Global Arguments path_forall {_} [_ _ _ _] _.

(** [path_forall] commutes with [inverse].  (This follows purely formally from the fact that its inverse [apD10] does.) *)
Definition path_forall_V {X : Type} {P : X -> Type} {f g : forall x, P x}
  (H : forall x, f x = g x)
: path_forall (fun x => (H x)^) = (path_forall H)^.
Proof.
  path_via' (path_forall (fun x => (apD10 (path_forall H) x)^)).
    apply ap, (@ap _ _ (fun h x => (h x)^)). apply inverse, eisretr.
  path_via' (path_forall (apD10 (path_forall H)^)).
    apply ap, inverse. apply path_forall; intros x. apply apD10_V.
  apply eissect.
Defined.

(** Note: this differs from the library function [apD10_path_forall] essentially only in having [pointwise_paths] unfolded in its type.  However, that is enough to make working with it more convenient — in particular, [rewrite] often works with this where it fails with [apD10_path_forall]. *)
Definition apD10_path_forall' {A : Type} {P : A -> Type}
  {f g : forall x, P x} (h : f == g) (x:A)
  : apD10 (path_forall h) x = h x
:= (apD10_path_forall _ _ h x).
(*TODO (high): consistentize the various ways of using [eisretr], [apD10_path_forall], etc. *)

End Funext.

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

Various things that don’t have a clear home.

*******************************************************************************)

Section Varia.

(* TODO (low): move to live with hfibers?  Where do they live? *)
Definition hfiber_incl {X Y:Type} (f:X -> Y) (y:Y) : hfiber f y -> X
:= pr1.

Fixpoint iterate {A:Type} (f:A->A) (n:nat)
:= fun x => match n with O => x | S n' => f (iterate f  n' x) end.

Fixpoint iterate_dep {A:Type} (f:A->A) (B:A->Type)
  (g : forall a:A, B a -> B (f a))
  (n:nat)
:= fun (x:A) (y:B x) => match n return (B (iterate f n x)) with
     | O => y
     | S n' => g _ (iterate_dep _ _ g n' x y) end.

Lemma moveR_I {AA BB : Type} (ff : AA -> BB) {H : IsEquiv ff} (x : AA) (y : BB)
  : y = ff x -> ff ^-1 y = x.
Proof.
  intros H_eq.  path_via (ff ^-1 (ff x)).
  apply ap, H_eq.  apply eissect.
Defined.

(* Compare [equiv_sigma_contr] in library. *)
Lemma isequiv_sigma_contr {X:Type} {Y:X->Type}
: (forall x:X, Contr (Y x)) -> IsEquiv (@projT1 X Y).
Proof.
  intros H. exact (equiv_isequiv (equiv_sigma_contr _)).
Defined.

Lemma isequiv_hfiber_incl_over_hprop {Y X : Type} (X_hprop : IsHProp X)
  (f : Y -> X) (x:X)
: IsEquiv (hfiber_incl f x).
Proof.
  refine (isequiv_sigma_contr _).
Defined.

End Varia.

Notation "A /\ B" := (A * B).
Notation "A <-> B" := ((A -> B) /\ (B -> A)).

(*
Local Variables:
coq-prog-name: "hoqtop"
End:
*)


(* Implementation of SHA 256. *)
(* https://nvlpubs.nist.gov/nistpubs/FIPS/NIST.FIPS.180-4.pdf *)
(* https://www.rfc-editor.org/rfc/rfc4634 *)
Require Import Lia
  Coq.Unicode.Utf8
  Coq.Bool.Bool
  Coq.Init.Byte
  Coq.NArith.NArith
  Coq.Strings.Byte
  Coq.ZArith.ZArith
  Coq.Lists.List.

Import Notations ListNotations.
Local Open Scope N_scope.

Section Wf_proof.

  Let f (a : N) := N.to_nat a.

  Definition zwf (x y : N) := (f x < f y)%nat.

  Lemma zwf_well_founded : well_founded zwf.
  Proof.
    exact (well_founded_ltof _ f).
  Defined.

  Lemma N_acc (x : N) : forall a, a < x -> Acc N.lt a.
  Proof.
    induction (zwf_well_founded x) as [z Hz IHz].
    intros ? Hxa.
    constructor; intros y Hy.
    eapply IHz with (y := a).
    unfold zwf. unfold f.
    abstract nia. abstract nia.
  Defined.

  Lemma N_lt_wf : well_founded N.lt.
  Proof.
    red; intros ?.
    constructor; intros y Hy.
    eapply N_acc with (x := a).
    exact Hy.
  Defined.

  Lemma N_Lt_wf : forall up, Acc (fun x y => x < y) up.
  Proof.
    intros up.
    pose proof (N_lt_wf up).
    exact H.
  Defined.

End Wf_proof.

Section Util.

  Definition np_total (np : N):  (np <? 256 = true) ->  byte.
  Proof.
    intros H.
    pose proof of_N_None_iff np as Hn.
    destruct (of_N np) as [b | ].
    + exact b.
    + exfalso; abstract (apply N.ltb_lt in H;
        intuition nia).
  Defined.

  Lemma np_true : forall np (H : np <? 256 = true) x, of_N np = Some x ->
    np_total np H = x.
  Proof.
    unfold np_total; intros * Heq.
    generalize (of_N_None_iff np).
    rewrite Heq; intros; reflexivity.
  Qed.

  Lemma nmod_256 : forall np, np mod 256 < 256.
  Proof.
    intros; eapply N.mod_lt; intro H;
    inversion H.
  Qed.

  Lemma nmod_256_dec : forall np, (np mod 256 <? 256) = true.
  Proof.
    intros; apply N.ltb_lt.
    apply nmod_256.
  Qed.

  Lemma N_eq_gt : forall up t : N, 256 <= up -> t = up / 256 -> 0 <=  t / 256 < t.
  Proof.
    intros up t Hup Ht.
    split.
    apply N.le_0_l.
    apply N.div_lt_upper_bound.
    nia.
    (* I know that 1 <= t *)
    assert (Hot: 1 <= t).
    rewrite Ht.
    apply N.div_le_lower_bound.
    nia.
    simpl. exact Hup. nia.
  Qed.

  (*log_{256} n = N.div (N.log2 n) (N.log2 256) *)
  Definition log256 n := N.div (N.log2 n) 8.

  Lemma ulogt : forall t : N, 1 <= t -> t + 1 <= 2 * 2 ^ N.log2 t.
  Proof.
    intros t Ht.
    assert (Htw : t + 1 = N.succ t).
    nia. rewrite Htw.
    apply N.lt_pred_le.
    rewrite N.pred_succ.
    assert (Hs : 2 * 2 ^ N.log2 t = 2 ^ (1 + N.log2 t)).
    rewrite N.pow_add_r. simpl. nia. rewrite Hs; clear Hs.
    assert (Hn : 1 + N.log2 t = N.succ (N.log2 t)).
    nia. assert (Htt : 0 < t). nia.
    pose proof  (N.log2_spec t Htt).
    rewrite Hn. nia.
  Qed.

  Lemma log256_unique : forall t a b c, 1 <= t -> 0 <= b -> 0 <= c < 2 ^ b -> a = t * 2 ^ b + c ->
    N.log2 a = b + N.log2 t.
  Proof.
    intros t a b c Ht Hb (Hc,H) EQ.
    apply N.log2_unique.
    - nia.
    - rewrite EQ. split.
      + rewrite N.pow_add_r.
        assert (Htz : 0 < t). nia.
        pose proof (N.log2_spec t Htz) as Hze.
        nia.
      + rewrite N.pow_succ_r.
        rewrite N.pow_add_r.
        rewrite N.mul_assoc.
        assert (t + 1 <= 2 * 2 ^ N.log2 t).
        apply ulogt. exact Ht.
        nia. nia.
  Qed.

  Lemma nlog256 : forall up t r, 1 <= t ->  r < 256 -> up = 256 * t + r ->
   log256 up =  1 + log256 t.
  Proof.
    intros ? ? ? Ht Hr Hup; unfold log256.
    assert (Htw : 256 = 2 ^ 8). reflexivity.
    assert (Hte : 0 <= 8). nia.
    assert (Hre : 0 <= r < 2^8). nia.
    assert (Hupn : up = t * 2^8 + r). nia.
    pose proof (log256_unique t up 8 r Ht Hte Hre Hupn).
    rewrite H.
    assert (Hs : (8 + N.log2 t) = (1 * 8 + N.log2 t))
      by nia.
    rewrite Hs. rewrite N.div_add_l.
    reflexivity. nia.
  Qed.

  Lemma nlogle256 : forall up : N, up < 256 -> 1%nat = N.to_nat (N.log2 up / 8 + 1).
  Proof.
    intros ? Hup.
    assert (Hun : 256 = 2^8).
    reflexivity. rewrite Hun in Hup.
    clear Hun.
    assert (Hn : N.log2 up < 8).
    destruct up. simpl. nia.
    apply N.log2_lt_pow2. nia.
    exact Hup.
    assert (Htn : N.log2 up / 8 = 0).
    apply N.div_small. exact Hn.
    rewrite Htn. nia.
  Qed.

  Lemma N_dec : forall n m : N, {n < m} + {m <= n}.
  Proof.
    intros [| n] [| m].
    + right; nia.
    + left; nia.
    + right; nia.
    + destruct (n <? m)%positive eqn:Ht.
      ++
      apply Pos.ltb_lt in Ht.
      left. abstract nia.
      ++
      apply Pos.ltb_ge in Ht.
      right. abstract nia.
  Defined.

  Lemma nlog_le256 : forall up : N, up < 256 <-> 0%nat = N.to_nat (N.log2 up / 8).
  Proof.
    intros ?; split; intro Hup.
    assert (Hun : 256 = 2^8).
    reflexivity. rewrite Hun in Hup.
    clear Hun.
    assert (Hn : N.log2 up < 8).
    destruct up. simpl. nia.
    apply N.log2_lt_pow2. nia.
    exact Hup.
    assert (Htn : N.log2 up / 8 = 0).
    apply N.div_small. exact Hn.
    rewrite Htn. nia.
    assert(Hp : {up < 256} + {256 <= up}).
    apply N_dec. destruct Hp.
    exact l. remember (N.div up 256) as t.
    remember (N.modulo up 256) as r.
    assert (Hp: up = 256 * t + r).
    subst t; subst r. apply N.div_mod'.
    assert (Ht: 1 <= t). subst t.
    apply N.div_le_lower_bound.
    nia. simpl. exact l.
    assert (Hr : 0 <= r < 256).
    rewrite Heqr.
    eapply N.mod_bound_pos.
    nia. nia.
    assert (H256 : 256 = 2^8).
    reflexivity. rewrite H256 in Hr.
    assert (H8 : 0 <= 8). nia.
    pose proof (log256_unique t up 8 r Ht H8 Hr).
    rewrite N.mul_comm, H256 in Hp.
    specialize(H Hp). rewrite H in Hup.
    assert (H18: 8 = 1 * 8).
    reflexivity.
    rewrite H18 in Hup at 1.
    rewrite N.div_add_l in Hup.
    rewrite N2Nat.inj_add in Hup.
    simpl in Hup. inversion Hup.
    nia.
  Qed.

End Util.

Section Fuel.

  (* passing this extra parameter n to faciliate the computation *)
  Fixpoint byte_list_from_N_fuel (n : nat) (up : N) : list byte :=
  match n with
  | 0%nat => [np_total (N.modulo up 256) (nmod_256_dec up)]
  | S n' =>
    let r := N.modulo up 256 in
    let t := N.div up 256 in
    List.cons (np_total r (nmod_256_dec up)) (byte_list_from_N_fuel n' t)
  end.

  Lemma byte_list_Sn : forall n np, byte_list_from_N_fuel (S n) np =
    List.cons (np_total (N.modulo np 256) (nmod_256_dec np)) (byte_list_from_N_fuel n (N.div np 256)).
  Proof.
    reflexivity.
  Qed.

  Lemma fuel_byte_list_length_correctness : forall (n : nat) (np : N),
    List.length (byte_list_from_N_fuel n np) = (1 + n)%nat.
  Proof.
    induction n; simpl; intro np.
    + reflexivity.
    + f_equal. apply IHn.
  Qed.

  (*
    Log256 np fuel is enough to compute the np. Also, the list
    is in little endien style, i.e., least significate digit first
  *)
  Definition byte_list_from_N (np : N) :=
    byte_list_from_N_fuel (N.to_nat (log256 np)) np.

  (* Turn the list into big endien *)
  Definition big_endien_list_N (np : N) :=
      List.rev (byte_list_from_N np).

  Lemma byte_list_length_correctness : forall np, List.length (byte_list_from_N np) =
    (1 + N.to_nat (log256 np))%nat.
  Proof.
    intros ?. unfold byte_list_from_N.
    rewrite fuel_byte_list_length_correctness;
    reflexivity.
  Qed.

  Lemma big_endien_list_correctness : forall np, List.length (big_endien_list_N np) =
    (1 + N.to_nat (log256 np))%nat.
  Proof.
    intros np. unfold big_endien_list_N.
    rewrite rev_length, byte_list_length_correctness;
    reflexivity.
  Qed.

  Fixpoint horner_eval_byte_list (l : list byte) :=
    match l with
    | List.nil => 0
    | List.cons h tl =>
          to_N h + 256 * horner_eval_byte_list tl
  end.

  Lemma eval_byte_list_cons : forall h tl, horner_eval_byte_list (List.cons h tl) =
    to_N h + 256 * horner_eval_byte_list tl.
  Proof.
    reflexivity.
  Qed.

  Lemma np_mod_total : forall np, to_N (np_total (np mod 256) (nmod_256_dec np)) = np mod 256.
  Proof.
    intros ?; unfold np_total.
    generalize (of_N_None_iff (np mod 256)).
    generalize (np_total_subproof (np mod 256) (nmod_256_dec np)).
    intros; destruct (of_N (np mod 256)) eqn:Htn.
    ++ apply to_of_N; exact Htn.
    ++ apply of_N_None_iff in Htn.
       assert (Hn : np mod 256 < 256).
       apply nmod_256. nia.
  Qed.

  Lemma byte_list_from_N_correct : forall np, horner_eval_byte_list (byte_list_from_N np) = np.
  Proof.
    intro np. unfold byte_list_from_N.
    remember (N.to_nat (log256 np)) as n.
    unfold log256 in Heqn. generalize dependent np.
    induction n.
    + simpl. intros ? Hn.
      apply nlog_le256 in Hn.
      unfold np_total.
      generalize (of_N_None_iff (np mod 256)).
      generalize (np_total_subproof (np mod 256) (nmod_256_dec np)).
      intros; destruct (of_N (np mod 256)) eqn:Htn.
      ++
        rewrite N.add_0_r.
        assert (Hnp : np mod 256 = np).
        apply N.mod_small; exact Hn.
        rewrite Hnp in Htn.
        apply to_of_N; exact Htn.
      ++
        assert (Hnp : np mod 256 = np).
        apply N.mod_small; exact Hn.
        rewrite Hnp in Htn.
        apply of_N_None_iff in Htn.
        nia.
    + intros ? Hn. rewrite byte_list_Sn,
      eval_byte_list_cons.
      destruct ( N_dec np 256) as [Hnl |  Hnr].
      ++ (* impossible case *)
        apply nlog_le256 in Hnl.
        rewrite <-Hnl in Hn. nia.
      ++
        specialize (IHn (N.div np 256)).
        assert (Hnp : np = 256 * (N.div np 256) + (N.modulo np 256)).
        apply N.div_mod. nia.
        assert (Hnt : 1 <= N.div np 256).
        apply N.div_le_lower_bound; nia.
        assert (Hnw : np mod 256 < 256).
        apply nmod_256.
        pose proof (nlog256 np _ _ Hnt Hnw Hnp).
        unfold log256 in H; rewrite H,  N2Nat.inj_add  in Hn;
        simpl in Hn. apply eq_add_S in Hn.
        specialize (IHn Hn). rewrite IHn.
        rewrite np_mod_total. nia.
  Qed.

End Fuel.

Section Wellfounded.

  (* uses well founded induction to compute the byte list, but it's very slow because of proof embedding *)
  Definition byte_list_sig (np : N) :  {l : list byte | List.length l = N.to_nat (log256 np + 1) ∧
    np = horner_eval_byte_list l}.
  Proof.
  induction (N_Lt_wf np) as [up Hacc IHuz].
  destruct (up <? 256) eqn:Hnp.
  + exists (List.cons (np_total up Hnp) List.nil).
    pose proof (proj1 (N.ltb_lt up 256) Hnp) as Ht.
    split.
    ++ abstract (simpl; apply nlogle256; exact Ht).
    ++ simpl. pose proof (np_true up Hnp).
      rewrite N.add_comm; simpl.
      destruct (of_N up) as [b | ] eqn:Hb.
      specialize(H b eq_refl); rewrite H.
      apply to_of_N_iff in Hb; intuition.
      apply of_N_None_iff in Hb; intuition.
      abstract nia.
  + pose proof (proj1 (N.ltb_ge up 256) Hnp) as Ht.
    refine(
      let r := N.modulo up 256 in
      let t := N.div up 256 in _ ).
    assert (Htt: t < up).
    abstract (unfold t;
      apply N.div_lt; nia).
    destruct (IHuz t Htt) as [lr Hlr].
    assert (Hr : r <? 256 = true).
    abstract (apply N.ltb_lt; unfold r;
    apply (nmod_256 up)).
    exists (List.cons (np_total r Hr) lr).
    split.
    ++
      simpl. assert (Hup: up = 256 * t + r).
      abstract (unfold t, r; rewrite <-N.div_mod with (b := 256);
      [reflexivity | nia]).
      rewrite nlog256 with (t := t) (r := r).
      abstract nia.
      assert (Hot: 1 <= t).
      abstract (unfold t;
      apply N.div_le_lower_bound; nia).
      exact Hot.
      apply N.ltb_lt in Hr. exact Hr.
      exact Hup.
    ++
      destruct Hlr as [Hlr1 Hlr2].
      rewrite eval_byte_list_cons, <-Hlr2.
      assert (Htn : to_N (np_total r Hr) = r).
      unfold np_total.
      generalize (of_N_None_iff r).
      destruct (of_N r) eqn:Hnr.
      intros. apply to_of_N_iff; exact Hnr.
      apply of_N_None_iff in Hnr.
      pose proof (proj1 (N.ltb_lt r 256) Hr).
      abstract nia. rewrite Htn; unfold r, t.
      rewrite N.add_comm.
      apply N.div_mod. abstract nia.
  Defined.

End Wellfounded.

Section Sha256.

  Definition word := 32.

  Definition add (x y : N) := (x + y) mod (2 ^ word).

  (* shiftr is fine but shift-left needs to be truncated *)
  Definition shift_left (x n : N) := (N.shiftl x n) mod (2 ^ word).

  (* right shift *)
  Definition shift_right (x n : N) := N.shiftr x n.

  (* bitwise and *)
  Definition bitwise_and (x y : N) := N.land x y.

  (* bitwise or *)
  Definition bitwise_or (x y : N) := N.lor x y.

  (* bitwise xor *)
  Definition bitwise_xor (x y : N) := N.lxor x y.

  (* flipping/negating the bits *)
  Definition bitwise_neg (x : N) := N.lnot x word.

  (* The rotate left (circular left shift) operation, where x is a w-bit word and n
  is  an  integer  with  0 ≤ n  < w,  is  defined  by  ROTL n(x)=(x  <<  n) \/ (x >> w - n).*)
  Definition ROTL (n x : N) :=  bitwise_or (shift_left x n)
    (shift_right x (word - n)).

  (*
  The  rotate  right  (circular  right  shift)  operation,  where  x  is  a  w-bit  word
  and n is  an integer with  0 ≤ n  < w, is defined by  ROTR  n(x)=(x >> n) \/ (x << w - n).
  *)
  Definition ROTR (n x : N) :=  bitwise_or (shift_right x n)
    (shift_left x (word - n)).

  (*
  The right shift operation, where x is a w-bit word and n is an integer with
  0 ≤ n < w, is defined by SHR n(x)=x >> n.
  *)
  Definition SHR (n x : N) := shift_right x n.

  Lemma rotl_rotr : forall (x ml : N), 0 <= ml < word -> ROTL ml x = ROTR (word - ml) x.
  Proof.
    intros ? ? Hm.
    unfold ROTL, ROTR,
    bitwise_or, shift_left,
    shift_right.
    assert(H32: word - (word - ml) = ml) by nia.
    rewrite H32, N.lor_comm.
    reflexivity.
  Qed.

  Lemma rotr_rotl : forall (x ml : N), 0 <= ml < word -> ROTR ml x = ROTL (word - ml) x.
  Proof.
    intros ? ? Hm.
    unfold ROTL, ROTR,
    bitwise_or, shift_left,
    shift_right.
    assert(H32: word - (word - ml) = ml) by nia.
    rewrite H32, N.lor_comm.
    reflexivity.
  Qed.

  (* Equation 4.2 *)
  Definition Ch (x y z : N) := bitwise_xor (bitwise_and x y)
    (bitwise_and (bitwise_neg x) z).

  (* Equation 4.3*)
  Definition Maj (x y z : N) := bitwise_xor (bitwise_xor (bitwise_and x y)
    (bitwise_and x z)) (bitwise_and y z).

  (* Equation 4.4 *)
  Definition Sigma₀ (x : N) := bitwise_xor (bitwise_xor (ROTR 2 x)
    (ROTR 13 x)) (ROTR 22 x).

  (* Equation 4.5 *)
  Definition Sigma₁ (x : N) :=  bitwise_xor (bitwise_xor (ROTR 6 x)
    (ROTR 11 x)) (ROTR 25 x).

  Definition sigma₀ x := bitwise_xor (bitwise_xor (ROTR 7 x)
    (ROTR 18 x)) (SHR 3 x).

  Definition sigma₁ x := bitwise_xor (bitwise_xor (ROTR 17 x)
     (ROTR 19 x)) (SHR 10 x).

  (* 5.3.3 *)
  (* superscript is not working *)
  Definition H₀ : list N := [
    0x6a09e667; 0xbb67ae85; 0x3c6ef372; 0xa54ff53a; 0x510e527f;
    0x9b05688c; 0x1f83d9ab; 0x5be0cd19].

  (* 4.2.2 SHA-224 and SHA-256 Constants  *)
  Definition K : list N := [
    0x428a2f98; 0x71374491; 0xb5c0fbcf; 0xe9b5dba5; 0x3956c25b; 0x59f111f1; 0x923f82a4; 0xab1c5ed5;
    0xd807aa98; 0x12835b01; 0x243185be; 0x550c7dc3; 0x72be5d74; 0x80deb1fe; 0x9bdc06a7; 0xc19bf174;
    0xe49b69c1; 0xefbe4786; 0x0fc19dc6; 0x240ca1cc; 0x2de92c6f; 0x4a7484aa; 0x5cb0a9dc; 0x76f988da;
    0x983e5152; 0xa831c66d; 0xb00327c8; 0xbf597fc7; 0xc6e00bf3; 0xd5a79147; 0x06ca6351; 0x14292967;
    0x27b70a85; 0x2e1b2138; 0x4d2c6dfc; 0x53380d13; 0x650a7354; 0x766a0abb; 0x81c2c92e; 0x92722c85;
    0xa2bfe8a1; 0xa81a664b; 0xc24b8b70; 0xc76c51a3; 0xd192e819; 0xd6990624; 0xf40e3585; 0x106aa070;
    0x19a4c116; 0x1e376c08; 0x2748774c; 0x34b0bcb5; 0x391c0cb3; 0x4ed8aa4a; 0x5b9cca4f; 0x682e6ff3;
    0x748f82ee; 0x78a5636f; 0x84c87814; 0x8cc70208; 0x90befffa; 0xa4506ceb; 0xbef9a3f7; 0xc67178f2].

  (* message m is in big endien style *)
  Context (m : list byte).

  (* Length of message bytes *)
  Let n := N.of_nat (List.length m).
  (* Length of message, in bits *)
  Let mbits := 8 * n.
  (* Hypothesis that message length, in bits, is less than 2^64*)
  Context {Hn : mbits < 2^64}.
  (* Length of to be padded *)
  Let k := Z.to_N (Zmod (448 - (Z.of_N mbits + 1)) 512).

  (*
    Suppose  that  the  length  of  the  message,  M,  is l bits.  Append the bit “1” to the end of
    the message, followed by k  zero bits, where  k is the smallest, non-negative solution to the
    equation l + k + 1 = 448 mod 512. Then  append  the  64-bit  block  that  is  equal  to  the
    number l expressed using a  binary  representation.  For  example,  the  (8-bit  ASCII)  message
    “abc”  has  length 8 * 3 = 24 bits, so the message is padded with a one bit, then
    (448 - (21 + 1) mod 512) = 423 zero bits, and then the message length, to become the
    512-bit padded message
  *)

  (* return v byte of zeros *)
  Fixpoint get_zero_bytes (v : nat) : list byte :=
  match v with
  | 0%nat => []
  | S v' => List.cons x00 (get_zero_bytes v')
  end.

  Lemma eval_zero_byte : forall v : nat, horner_eval_byte_list (get_zero_bytes v) = 0%N.
  Proof.
    induction v.
    + simpl; reflexivity.
    + simpl; rewrite IHv;
      reflexivity.
  Qed.

  Lemma get_zero_bytes_len : forall v, List.length (get_zero_bytes v) = v%nat.
  Proof.
    induction v.
    + simpl; reflexivity.
    + simpl; rewrite IHv;
      reflexivity.
  Qed.

  (* x80 followed by v zero bytes *)
  Definition message_padding (v : nat) : list byte :=
  match v with
  | 0%nat => []
  | S v' => List.cons x80 (get_zero_bytes v')
  end.

  Lemma message_padding_app : forall v, message_padding (S v) = List.cons x80 (get_zero_bytes v).
  Proof.
    simpl; destruct v.
    + reflexivity.
    + simpl; reflexivity.
  Qed.

  Lemma message_padding_length : forall v, List.length (message_padding v) = v.
  Proof.
    unfold message_padding.
    induction v.
    + simpl; reflexivity.
    + simpl; rewrite get_zero_bytes_len;
      reflexivity.
  Qed.

  (* if v is non-zero then padding evaluates to x80*)
  Lemma message_padding_correct : forall v, (0 < v)%nat -> horner_eval_byte_list (message_padding v) = to_N x80.
  Proof.
    destruct v.
    + intro H; nia.
    + intros H. rewrite message_padding_app, eval_byte_list_cons,
      eval_zero_byte; nia.
  Qed.

  (* 8 bytes, or 64 bits, are needed to represent the message length *)
  Lemma upper_bound_on_msg_len : (N.to_nat (log256 mbits + 1) <= 8)%nat.
  Proof.
    unfold log256; unfold mbits.
    assert (Hnt : N.log2 (8 * n) < 64).
    destruct n. simpl. nia.
    apply N.log2_lt_pow2. nia.
    exact Hn.
    assert (Hnw: N.log2 (8 * n) / 8 < 8).
    apply N.div_lt_upper_bound with (q := 8).
    nia. exact Hnt.
    nia.
  Qed.

  (* lb is length byte *)
  Definition append_zero_in_length_byte (lb : list byte) : list byte :=
    let nl := List.length lb in
    if (nl <=? 8)%nat then get_zero_bytes (8 - nl) ++ lb
    else lb. (* impossible case *)

  (* if the length byte is less the 8, then append it with zero,
    in big endian style, to turn it into 8 bytes*)
  Definition message_length_byte : list byte :=
    append_zero_in_length_byte (big_endien_list_N mbits).

  (* proof that if the message length bytes is equal to 8 bytes *)
  Lemma message_length_byte_8 : (List.length message_length_byte = 8)%nat.
  Proof.
    unfold message_length_byte,
    append_zero_in_length_byte.
    assert (Ht: (List.length (big_endien_list_N mbits) <= 8)%nat).
    rewrite big_endien_list_correctness.
    unfold log256.
    assert (Hnt : N.log2 mbits < 64).
    destruct mbits. simpl. nia.
    apply N.log2_lt_pow2. nia.
    exact Hn.
    assert (Hwt: N.log2 mbits / 8 < 8).
    apply N.div_lt_upper_bound; nia.
    nia.
    apply Nat.leb_le in Ht.
    rewrite Ht.
    apply Nat.leb_le in Ht.
    rewrite app_length.
    rewrite get_zero_bytes_len.
    nia.
  Qed.

  Lemma push_N : forall a : Z, (0 <= a)%Z -> (1 + Z.to_N a) = Z.to_N (1 + a).
  Proof.
    intros. rewrite Z2N.inj_add.
    all: nia.
  Qed.

  Lemma mod_eq_custom : forall (a b : Z), (0 < b)%Z -> Z.modulo a b = (a - b * (a / b))%Z.
  Proof.
    intros a b Hb; rewrite Zmod_eq; nia.
  Qed.

  (* carrying this extra information of w to simplify other proofs *)
  Lemma k_plus_gen : exists w : N, k =  8 * w + 7 /\
    (w = (Z.to_N (55 - Z.of_N n - 64 * ((447 - Z.of_N (8 * n)) / 512)))) /\
    (0 <= (55 - Z.of_N n - 64 * ((447 - Z.of_N (8 * n)) / 512)))%Z.
  Proof.
    unfold k, mbits.
    assert (H: (448 - (Z.of_N (8 * n) + 1))%Z = (447 - (Z.of_N (8 * n)))%Z).
    nia. rewrite H.
    assert (Hp : (0 <= (447 - Z.of_N (8 * n)) mod 512 < 512)%Z).
    apply Z.mod_pos_bound; nia.
    rewrite mod_eq_custom.
    assert (Ht: (447 - Z.of_N (8 * n) - 512 * ((447 - Z.of_N (8 * n)) / 512))%Z =
        (8 * (55 - Z.of_N n - 64 * ((447 - Z.of_N (8 * n)) / 512)) + 7)%Z).
    nia. rewrite Ht.
    exists (Z.to_N (55 - Z.of_N n - 64 * ((447 - Z.of_N (8 * n)) / 512))).
    rewrite mod_eq_custom in Hp.
    all:nia.
  Qed.

  Lemma k_plus_gen_one : exists w : N, 1 + k = 8 * (w + 1) /\
    (w = (Z.to_N (55 - Z.of_N n - 64 * ((447 - Z.of_N (8 * n)) / 512)))) /\
    (0 <= (55 - Z.of_N n - 64 * ((447 - Z.of_N (8 * n)) / 512)))%Z.
  Proof.
    destruct k_plus_gen as [x [Hx H]].
    exists x. rewrite Hx. nia.
  Qed.

  (* k + 1 is divisible by 8*)
  Lemma k_plus_one_div_8 : N.modulo (1 + k) 8 = 0.
  Proof.
    destruct k_plus_gen as [x [H1 H2]].
    assert (Ht : 1 + (8 * x + 7) =  (x + 1) * 8).
    nia. rewrite H1, Ht.
    rewrite N.mod_mul.
    reflexivity. nia.
  Qed.

  (* compute the  wt *)
  Let wt := N.div (1 + k) 8.

  (* 0 < wt *)
  Lemma wt_exact_val : wt = Z.to_N (56 - Z.of_N n - 64 * ((447 - Z.of_N (8 * n)) / 512)) /\
    (0 < wt).
  Proof.
    destruct k_plus_gen_one as [x [Hx [Hy Hz]]].
    assert (wt = x + 1). unfold wt.
    rewrite Hx. rewrite N.mul_comm, N.div_mul.
    reflexivity. nia.
    rewrite H, Hy.
    nia.
  Qed.

  Lemma sha_64_byte : n + wt + 8 = 64 * Z.to_N (1 -  ((447 - Z.of_N (8 * n)) / 512)) ∧
    (0 < (64 - 64 * ((447 - Z.of_N (8 * n)) / 512)))%Z.
  Proof.
    destruct wt_exact_val as [H1 H2].
    nia.
  Qed.

  (* message + padding + message_length should be divisible by 64 (byte)*)
  Lemma div_64 : N.modulo (n +  wt + 8) 64 = 0.
  Proof.
    destruct sha_64_byte as [H1 H2].
    rewrite H1, N.mul_comm, N.mod_mul.
    reflexivity. nia.
  Qed.

  (* Number of 64 byte, 512 bits, blocks in the message *)
  Let ms := N.div (n + wt + 8) 64.

  Definition prepared_message : list byte :=
    m ++ message_padding (N.to_nat wt) ++ message_length_byte.

  Lemma prepared_message_correctness : List.length prepared_message = N.to_nat (n + wt + 8).
  Proof.
    unfold prepared_message.
    repeat rewrite app_length.
    rewrite message_padding_length,
    message_length_byte_8.
    nia.
  Qed.

  (* turns 4 bytes --32 bit--, 'a' most significant and 'd' least significant, to N *)
  Definition big_endien_32_bit_to_N (a b c d : byte) : N :=
    ((to_N a * 256 + to_N b) * 256 + to_N c) * 256 + to_N d.

  (* Section 5.2.1:
     For SHA-1, SHA-224 and SHA-256, the message and its padding are parsed into
     N 512-bit blocks, M(1), M(2),...M(N). Since the 512 bits of the input block
     may be expressed as sixteen 32- bit words, the first 32 bits of message
     block i are denoted M0(i), M1(i), and so on up to M15(i).
     (i < N.to_nat ms)%nat
     (j < 16)%nat
   *)
  Definition M (i j : nat) : N := big_endien_32_bit_to_N
    (nth (64 * i + 4 * j) prepared_message x00)
    (nth (64 * i + 4 * j + 1) prepared_message x00)
    (nth (64 * i + 4 * j + 2) prepared_message x00)
    (nth (64 * i + 4 * j + 3) prepared_message x00).

  (* [n-1; n-2; .... 0] *)
  Fixpoint from_n (n : nat) :=
    match n with
    | 0%nat => []
    | S n' => n' :: (from_n n')
    end.

  (* [0, 1, 2, .... n-1]*)
  Definition upto_n (n : nat) := List.rev (from_n n).

  (* From section 6.2.2 (step 1):
     Prepare the message schedule, {W(t)}:
     W(t) = Mt(i) for 0 <= t <= 15
     W(t) = σ{1,256}(W_(t-2)) + W(t-7) + σ{0,256}(W(t-15)) + W(t-16) for 16 <= t <= 63
  *)

  Definition W (i : nat) : list N :=
    List.fold_left
    (fun (acc : list N) (t : nat) =>
      let wtp :=
        if (t <? 16)%nat then M i t (* copy the M i into 16 (32 bit) N into acc *)
        else
          let a := nth (t - 2) acc 0 in
          let b := nth (t - 7) acc 0 in
          let c := nth (t - 15) acc 0 in
          let d := nth (t - 16) acc 0 in
          add (add (add (sigma₁ a) b) (sigma₀ c)) d
      in acc ++ [wtp]) (upto_n 64) [].

  (* Steps 2, 3, and 4 in section 6.2.2. *)
  Definition sha256_intermediate (W : list N) (H : list N) : list N :=
    (* step 2 *)
    let a := nth 0 H 0 in
    let b := nth 1 H 0 in
    let c := nth 2 H 0 in
    let d := nth 3 H 0 in
    let e := nth 4 H 0 in
    let f := nth 5 H 0 in
    let g := nth 6 H 0 in
    let h := nth 7 H 0 in
    (* Step 3 *)
    let '(a, b, c, d, e, f, g, h) :=
    List.fold_left
    (fun '(a, b, c, d, e, f, g, h) t =>
      let T₁ := add (add (add (add h (Sigma₁ e)) (Ch e f g)) (nth t K 0)) (nth t W 0) in
      let T₂ := add (Sigma₀ a) (Maj a b c) in
      let h := g in
      let g := f in
      let f := e in
      let e := add d T₁ in
      let d := c in
      let c := b in
      let b := a in
      let a := add T₁ T₂ in
      (a, b, c, d, e, f, g, h)) (upto_n 64) (a, b, c, d, e, f, g, h)
    in
    (* step 4: compute Hi *)
    [add a (nth 0 H 0); add b (nth 1 H 0); add c (nth 2 H 0);
    add d (nth 3 H 0); add e (nth 4 H 0); add f (nth 5 H 0);
    add g (nth 6 H 0); add h (nth 7 H 0)].

  Definition sha256 :=
    List.fold_left
    (fun H i => sha256_intermediate (W i) H)
    (upto_n (N.to_nat ms)) H₀.

End Sha256.

From Coq Require Import String Ascii.

Definition concat_bytes (bs : list byte) : N :=
    List.fold_left (fun acc b => acc * (N.shiftl 1 8) + to_N b) bs 0.

Definition sha256_string (s : string) :=
  concat_bytes (List.flat_map big_endien_list_N (sha256 (list_byte_of_string s))).

(* start of sha256 tests *)
(* https://www.di-mgt.com.au/sha_testvectors.html *)

Lemma sha256_1st : sha256_string "abc" =
  0xba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad.
Proof.
 Time vm_compute; reflexivity.
Qed.

Lemma sha256_2nd : sha256_string "" =
  0xe3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855.
Proof.
  Time vm_compute; reflexivity.
Qed.

Lemma sha256_3rd : sha256_string  "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" =
  0x248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1.
Proof.
  Time vm_compute; reflexivity.
Qed.

Lemma sha256_4th : sha256_string ("abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghij" ++
 "klmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu") =
  0xcf5b16a778af8380036ce59e7b0492370b249b11e8f07a51afac45037afee9d1.
Proof.
  Time vm_compute; reflexivity.
Qed.

(* end of sha256 *)


Require Import Logic_Type.
(** Basic homotopy-theoretic approach to paths. *)

(** The [Hint Resolve @idpath] line below means that Coq's [auto]
   tactic will automatically perform [apply idpath] if that leads to a
   successful solution of the current goal. For example if we ask it
   to construct a path [x = x], [auto] will find the identity path
   [idpath x], thanks to the [Hint Resolve].

   In general we should declare [Hint Resolve] on those theorems which
   are not very complicated but get used often to finish off
   proofs. Notice how we use the non-implicit version [@idpath] (if we
   try [Hint Resolve idpath] Coq complains that it cannot guess the
   value of the implicit argument [A]).  *)

(** The following automated tactic applies induction on paths and then
    [auto], which will also try [idpath]. It can handle many easy
    statements. *)

Ltac path_induction :=
  intros; repeat progress (
    match goal with
      | [ p : _ = _  |- _ ] => induction p
      | _ => idtac
    end
  ); auto.

(** You can read the above tactic definition as follows. We first perform
   [intros] to move hypotheses into the context. Then we repeat while there
   is still progress: if there is a path [p] in the context, apply
   induction to it, otherwise perform the [idtac] which does nothing (and
   so no progress is made and we stop). After that, we perform an [auto].

   The notation [ [... |- ... ] ] is a pattern for contexts. To the left of
   the symbol [|-] we list hypotheses and to the right the goal. The
   underscore means "anything".

   In summary [path_induction] performs as many inductions on paths as it
   can, then it uses [auto]. *)

(** We now define the basic operations on paths, starting with concatenation. *)
Definition concat {A} {x y z : A} : (x = y) -> (y = z) -> (x = z).
Proof.
  intros p q.
  induction p.
  exact q.
Defined.

(** The concatenation of paths [p] and [q] is denoted as [p @ q]. *)

Notation "p @ q" := (concat p q) (at level 60, right associativity).

(** A definition like [concat] can be used in two ways. The first and
   obvious way is as an operation which concatenates together two
   paths. The second use is a proof tactic when we want to construct a
   path [x = z] as a concatenation of paths [x = y = z]. This is
   done with [apply @concat], see examples below. We will actually
   define a tactic [path_via] which uses [concat] but is much smarter
   than just the direct application [apply @concat]. *)

(** Notation for the opposite of a path [p] is [! p]. *)

Notation "! p" := (identity_sym p) (at level 50).

Arguments identity_sym {A} {x y} _.
Arguments identity {A} a _.
Arguments identity_refl {A a} , [A] a.

Arguments identity_ind [A] a P _ y _.
Arguments identity_rec [A] a P _ y _.
Arguments identity_rect [A] a P _ y _.

(* compatibility with init/ *)
Notation idpath := identity_refl.
Notation opposite := identity_sym.
Notation paths := identity.
Notation paths_rect := identity_rect.

(** Next we give names to the basic properties of concatenation of
   paths. Note that all statements are "up to a higher path", e.g.,
   the composition of [p] and the identity path is not equal to [p]
   but only connected to it with a path. *)

(** We are going to create a rewrite hints database called [paths], to
   be used with the rewriting facilities. We must be a bit careful about
   putting hints in [paths], lest we end up with a cycle of rewrite
   rules that will spin forever. What is needed is a well-founded
   measure which guarantees that the left-hand side of a rewrite rule is
   larger than the right-hand size. Here is an attempt to describe
   such a measure. It is the lexicographic order of the following
   simpler measures, where the most significant measure comes first:

   - number of occurences of [equiv_compose]
   - number of occurences of [equiv_inverse]
   - number of occurences of [inverse] (from [Equivalences])
   - number of occurences of [total_path]
   - depth at which [happly_dep] occurs
   - depth at which [map_dep] occurs
   - number of occurences of [concat]
   - depth at which [transport] occurs
   - depth at which [happly] occurs
   - number of occurences of [composition]
   - depth at which [map] occurs
   - depth at which [opposite] occurs
   - number if occurences of [idpath]
   - size of the expression

   This means, that in each rewrite rule that is added to the [paths]
   hints database, the number of occurences of [map_dep] has to decrease, or
   stay the same and the number of occurences of [concat] has to
   decrease, or stay the same and...., or the size of the formula has to
   decrease.
*)

(** The following lemmas say that up to higher paths, the paths form a
   1-groupoid. *)

Lemma idpath_left_unit {A} {x y : A} (p : x = y) : idpath x @ p = p.
Proof.
  path_induction.
Defined.

Hint Rewrite @idpath_left_unit : paths.

Lemma idpath_right_unit {A} {x y : A} (p : x = y) : (p @ idpath y) = p.
Proof.
  path_induction.
Defined.

Hint Rewrite @idpath_right_unit : paths.

Lemma opposite_right_inverse {A} {x y : A} (p : x = y) : (p @ !p) = idpath x.
Proof.
 path_induction.
Defined.

Hint Rewrite @opposite_right_inverse : paths.

Lemma opposite_left_inverse {A} {x y : A} (p : x = y) : (!p @ p) = idpath y.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_left_inverse : paths.

(* Often the inverses end up associated in the wrong way, so we also add
   the following variants. *)

Lemma opposite_right_inverse_with_assoc_left {A} {x y z : A} (p : x = y) (q : y = z) :
  (p @ q) @ !q = p.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_right_inverse_with_assoc_left : paths.

Lemma opposite_left_inverse_with_assoc_left {A} {x y z : A} (p : x = y) (q : z = y) :
  (p @ !q) @ q = p.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_left_inverse_with_assoc_left : paths.

Lemma opposite_right_inverse_with_assoc_right {A} {x y z : A} (p : y = x) (q : y = z) :
  p @ (!p @ q) = q.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_right_inverse_with_assoc_right : paths.

Lemma opposite_left_inverse_with_assoc_right {A} {x y z : A} (p : x = y) (q : y = z) :
  !p @ (p @ q) = q.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_right_inverse_with_assoc_left : paths.

Lemma opposite_left_inverse_with_assoc_both {A}
  {x y z w : A} (p : x = y) (q : z = y) (r : y = w) :
  (p @ !q) @ (q @ r) = p @ r.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_left_inverse_with_assoc_both : paths.

Lemma opposite_right_inverse_with_assoc_both {A}
  {x y z w : A} (p : x = y) (q : y = z) (r : y = w) :
  (p @ q) @ (!q @ r) = p @ r.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_right_inverse_with_assoc_both : paths.

Lemma opposite_concat {A} {x y z : A} (p : x = y) (q : y = z) : !(p @ q) = !q @ !p.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_concat : paths.

Lemma opposite_idpath {A} {x : A} : !(idpath x) = idpath x.
Proof.
  reflexivity.
Defined.

Hint Rewrite @opposite_idpath : paths.

Lemma opposite_opposite {A} {x y : A} (p : x = y) : !(! p) = p.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_opposite : paths.

Lemma concat_associativity {A} (w x y z : A) (p : w = x) (q : x = y) (r : y = z) :
  (p @ q) @ r = p @ (q @ r).
Proof.
  path_induction.
Defined.

(** Now we move on to the 2-groupoidal structure of a type. Concatenation
   of 2-paths along 1-paths is just ordinary concatenation in a path type,
   but we need a new name and notation for concatenation of 2-paths along
   points. *)

Definition concat2 {A} {x y z : A} {p p' : x = y} {q q' : y = z} :
  (p = p') -> (q = q') -> (p @ q = p' @ q').
Proof.
  path_induction.
Defined.

Notation "p @@ q" := (concat2 p q) (at level 60).

(** We also have whiskering operations which compose a 1-path with
   a 2-path. We do not introduce even more notation, however. *)

Definition whisker_right {A} {x y z : A} {p p' : x = y} (q : y = z) :
  (p = p') -> (p @ q = p' @ q).
Proof.
  path_induction.
Defined.

Definition whisker_left {A} {x y z : A} {q q' : y = z} (p : x = y) :
  (q = q') -> (p @ q = p @ q').
Proof.
  path_induction.
Defined.

(** Basic properties of whiskering. *)

Definition whisker_right_toid {A} {x y : A} (p : x = x) (q : x = y) :
  (p = idpath x) -> (p @ q = q).
Proof.
  intro a.
  apply @concat with (y := idpath x @ q).
  apply whisker_right. assumption.
  apply idpath_left_unit.
Defined.

Definition whisker_right_fromid {A} {x y : A} (p : x = x) (q : x = y) :
  (idpath x = p) -> (q = p @ q).
Proof.
  intros a.
  apply @concat with (y := idpath x @ q).
  apply opposite, idpath_left_unit.
  apply whisker_right. assumption.
Defined.

Definition whisker_left_toid {A} {x y : A} (p : y = y) (q : x = y) :
  (p = idpath y) -> (q @ p = q).
Proof.
  intros a.
  apply @concat with (y := q @ idpath y).
  apply whisker_left. assumption.
  apply idpath_right_unit.
Defined.

Definition whisker_left_fromid {A} {x y : A} (p : y = y) (q : x = y) :
  (idpath y = p) -> (q = q @ p).
Proof.
  intros a.
  apply @concat with (y := q @ idpath y).
  apply opposite, idpath_right_unit.
  apply whisker_left. assumption.
Defined.

(** The interchange law for whiskering. *)

Definition whisker_interchange {A} {x y z : A} (p p' : x = y) (q q' : y = z)
  (a : p = p') (b : q = q') :
  (whisker_right q a) @ (whisker_left p' b) = (whisker_left p b) @ (whisker_right q' a).
Proof.
  path_induction.
Defined.

(** The interchange law for concatenation. *)

Definition concat2_interchange {A} {x y z : A} (p p' p'' : x = y) (q q' q'' : y = z)
  (a : p = p') (b : p' = p'') (c : q = q') (d : q' = q'') :
  (a @@ c) @ (b @@ d) = (a @ b) @@ (c @ d).
Proof.
  path_induction.
Defined.

(** Now we consider the application of functions to paths. *)

(** A path [p : x = y] in a space [A] is mapped by [f : A -> B] to a
   path [map f p : f x = f y] in [B]. *)

Lemma map {A B} {x y : A} (f : A -> B) : (x = y) -> (f x = f y).
Proof.
  path_induction.
Defined.

(** Taking opposites of 1-paths is functorial on 2-paths. *)

Definition opposite2 {A} {x y : A} {p q : x = y} (a : p = q) : (!p = !q)
  := map opposite a.
(*Proof.
  path_induction.
Defined.*)

(** The next two lemmas state that [map f p] is "functorial" in the path [p]. *)

Lemma idpath_map {A B} {x : A} (f : A -> B) : map f (idpath x) = idpath (f x).
Proof.
  reflexivity.
Defined.

Hint Rewrite @idpath_map : paths.

Lemma concat_map {A B} {x y z : A} (f : A -> B) (p : x = y) (q : y = z) :
  map f (p @ q) = (map f p) @ (map f q).
Proof.
  path_induction.
Defined.

Hint Rewrite @concat_map : paths.

Lemma opposite_map {A B} {x y : A} (f : A -> B) (p : x = y) :
  map f (! p) = ! map f p.
Proof.
  path_induction.
Defined.

Hint Rewrite @opposite_map : paths.

(** It is also the case that [map f p] is functorial in [f].  *)

Lemma idmap_map {A} {x y : A} (p : x = y) : map (idmap A) p = p.
Proof.
  path_induction.
Defined.

Hint Rewrite @idmap_map : paths.

Lemma compose_map {A B C} (f : A -> B) (g : B -> C) {x y : A} (p : x = y) :
  map (g o f) p = map g (map f p).
Proof.
  path_induction.
Defined.

Hint Rewrite @compose_map : paths.

Lemma constmap_map {A B : Type} {b : B} {x y : A} (p : x = y) :
  map (fun _ => b) p = idpath b.
Proof.
  path_induction.
Defined.

Hint Rewrite @constmap_map : paths.

(** We can also map paths between paths. *)

Definition map2 {A B} {x y : A} (p q : x = y) (f : A -> B) :
  p = q -> (map f p = map f q)
  := map (map f).

(** The type of "homotopies" between two functions [f] and [g] is
   [forall x, f x = g x].  These can be derived from "paths" between
   functions [f = g]; the converse is function extensionality. *)

Definition happly {A B} {f g : A -> B} : (f = g) -> (forall x, f x = g x) :=
  fun p x => map (fun h => h x) p.

(** Similarly, [happly] for dependent functions. *)

Definition happly_dep {A} {P : A -> Type} {f g : forall x, P x} :
  (f = g) -> (forall x, f x = g x) :=
  fun p x => map (fun h => h x) p.

(** [happly] preserves path-concatenation and opposites. *)

Lemma happly_concat {A B} (f g h : A -> B) (p : f = g) (q : g = h) (x : A) :
  happly (p @ q) x = happly p x @ happly q x.
Proof.
  path_induction.
Defined.

Hint Rewrite @happly_concat : paths.

Lemma happly_opp {A B} (f g : A -> B) (p : f = g) (x : A) :
  happly (!p) x = !happly p x.
Proof.
  path_induction.
Defined.

Hint Rewrite @happly_opp : paths.

Lemma happly_dep_concat {A} P (f g h : forall a : A, P a) (p : f = g) (q : g = h) (x:A) :
  happly_dep (p @ q) x = happly_dep p x @ happly_dep q x.
Proof.
  path_induction.
Defined.

Hint Rewrite @happly_dep_concat : paths.

Lemma happly_dep_opp {A} P (f g : forall a : A, P a) (p : f = g) (x : A) :
  happly_dep (!p) x = !happly_dep p x.
Proof.
  path_induction.
Defined.

Hint Rewrite @happly_dep_opp : paths.

(** How happly interacts with map. *)

Lemma map_precompose {A B C} (f g : B -> C) (h : A -> B)
  (p : f = g) (a : A) :
  happly (map (fun f' => f' o h) p) a = happly p (h a).
Proof.
  path_induction.
Defined.

Lemma map_postcompose {A B C} (f g : A -> B) (h : B -> C)
  (p : f = g) (a : A) :
  happly (map (fun f' => h o f') p) a = map h (happly p a).
Proof.
  path_induction.
Defined.

Lemma map_precompose_dep {A B} P (f g : forall b : B, P b) (h : A -> B)
  (p : f = g) (a : A) :
  happly_dep (map (fun f' => fun a => f' (h a)) p) a = happly_dep p (h a).
Proof.
  path_induction.
Defined.

(** Paths in cartesian products. *)

Definition prod_path {X Y} {x x' : X} {y y' : Y} :
  (x = x') -> (y = y') -> ((x, y) = (x', y')).
Proof.
  path_induction.
Defined.

(** We declare some more [Hint Resolve] hints, now in the "hint
   database" [path_hints].  In general various hints (resolve,
   rewrite, unfold hints) can be grouped into "databases". This is
   necessary as sometimes different kinds of hints cannot be mixed,
   for example because they would cause a combinatorial explosion or
   rewriting cycles.

   A specific [Hint Resolve] database [db] can be used with [auto with db]. *)

Hint Resolve
  idpath opposite
  idpath_left_unit idpath_right_unit
  opposite_right_inverse opposite_left_inverse
  opposite_concat opposite_idpath opposite_opposite
  concat2
  whisker_right whisker_left
  whisker_right_toid whisker_right_fromid
  whisker_left_toid whisker_left_fromid
  opposite2
  map idpath_map concat_map idmap_map compose_map opposite_map
  map2
 : path_hints.

(** We can add more hints to the database later. *)

(** What follows is a long series of tactics which were used before
   Coq supported rewriting with [paths]. They are still here mostly
   for backward compatibility and because some people might be used
   to them. Eventually we how to get rid of them because the tactic
   [hott_simpl] defined below supersedes most of them. *)

(** Like [simpl], but for paths. It just uses the [paths] rewrite
   database but it might get fancier in the future. *)

Ltac hott_simpl :=
  autorewrite with paths in * |- * ; auto with path_hints.

(** For some reason, [apply happly] and [apply happly_dep] often seem
   to fail unification.  This tactic does the work that I think they
   should be doing. *)

Ltac apply_happly_to f' g' x' :=
  first [
      apply @happly with (f := f') (g := g') (x := x')
    | apply @happly_dep with (f := f') (g := g') (x := x')
  ].

Ltac apply_happly :=
  match goal with
    | |- ?f ?x = ?g ?x =>
      apply_happly_to f g x
    | |- ?f1 (?f2 ?x) = ?g ?x =>
      change ((f1 o f2) x = g x);
      apply_happly_to (f1 o f2) g x
    | |- ?f ?x = ?g1 (?g2 ?x) =>
      change (f x = (g1 o g2) x);
      apply_happly_to f (g1 o g2) x
    | |- ?f1 (?f2 ?x) = ?g1 (?g2) ?x =>
      change ((f1 o f2) x = (g1 o g2) x);
      apply_happly_to (f1 o f2) (g1 o g2) x
  end.

(** The following tactic is intended to be applied when we want to
   find a path between two expressions which are largely the same, but
   differ in the value of some subexpression.  Therefore, it does its
   best to "peel off" all the parts of both sides that are the same,
   repeatedly, until only the "core" bit of difference is left.  Then
   it performs an [auto] using the [path_hints] database. *)

Ltac path_simplify :=
  repeat progress first [
      apply whisker_left
    | apply whisker_right
    | apply @map
    ]; hott_simpl.

(** The following variant allows the caller to supply an additional
   lemma to be tried (for instance, if the caller expects the core
   difference to be resolvable by using a particular lemma). *)

Ltac path_simplify' lem :=
  repeat progress first [
      apply whisker_left
    | apply whisker_right
    | apply @map
    | apply lem
    | apply opposite; apply lem
    ]; hott_simpl.

(* This one takes a tactic rather than a lemma. *)

Ltac path_simplify'' tac :=
  repeat progress first [
      apply whisker_left
    | apply whisker_right
    | apply @map
    | tac
    | apply opposite; tac
    ]; hott_simpl.

(** These tactics are used to construct a path [a = b] as a
   composition of paths [a = x] and [x = b].  They then apply
   [path_simplify] to both paths, along with possibly an additional
   lemma supplied by the user. *)

Ltac path_via mid :=
  apply @concat with (y := mid); auto with path_hints.

Ltac path_using mid lem :=
  apply @concat with (y := mid); path_simplify' lem.

Ltac path_using' mid tac :=
  apply @concat with (y := mid); path_simplify'' tac.

(** This variant does not call path_simplify. *)

Ltac path_via' mid :=
  apply @concat with (y := mid).

(** And this variant does not actually do composition; it just changes
   the form of one of the goals. *)

Ltac path_change mid :=
  match goal with
    |- ?source = ?target =>
      first [ change (source = mid) | change (mid = target) ]
  end; path_simplify.

(** Here are some tactics for reassociating concatenations.  The
   tactic [associate_right] associates both source and target of the
   goal all the way to the right, and dually for [associate_left]. *)

Ltac associate_right_in s :=
  match s with
    context cxt [ (?a @ ?b) @ ?c ] =>
    let mid := context cxt[a @ (b @ c)] in
      path_using mid concat_associativity
  end.

Ltac associate_right :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ associate_right_in s | associate_right_in t ]
    end
  ).

Ltac associate_left_in s :=
  match s with
    context cxt [ ?a @ (?b @ ?c) ] =>
    let mid := context cxt[(a @ b) @ c] in
      path_using mid concat_associativity
  end.

Ltac associate_left :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ associate_left_in s | associate_left_in t ]
    end
  ).

(** This tactic unwhiskers by paths on both sides, reassociating as
   necessary. *)

Ltac unwhisker :=
  associate_left;
  repeat progress apply whisker_right;
  associate_right;
  repeat progress apply whisker_left.

(** Here are some tactics for eliminating identities.  The tactic
   [cancel_units] tries to remove all identity paths and functions
   from both source and target of the goal. *)

Ltac cancel_units_in s :=
  match s with
    | context cxt [ idpath ?a @ ?p ] =>
      let mid := context cxt[p] in path_using mid idpath_left_unit
    | context cxt [ ?p @ idpath ?a ] =>
      let mid := context cxt[p] in path_using mid idpath_right_unit
    | context cxt [ map ?f (idpath ?x) ] =>
      let mid := context cxt[idpath (f x)] in path_using mid idpath_map
    | context cxt [ map (idmap _) ?p ] =>
      let mid := context cxt[p] in path_using mid idmap_map
    | context cxt [ ! (idpath ?a) ] =>
      let mid := context cxt[idpath a] in path_using mid opposite_idpath
    | context cxt [ map (fun _ => ?a) ?p ] =>
      let mid := context cxt[idpath a] in path_using mid constmap_map
    | context cxt [ ! map (fun _ => ?a) ?p ] =>
      let mid := context cxt[! idpath a] in path_using mid constmap_map
  end.

Ltac cancel_units :=
  repeat (
    match goal with
      |- ?s = ?t => first [ cancel_units_in s | cancel_units_in t ]
    end
  ).

(** And some tactics for eliminating matched pairs of opposites. *)

(** This is an auxiliary tactic which performs one step of a
   reassociation of [s] (which is the source or target of a path) so
   as to get [!p] to be closer to being concatenated on the left with
   something irreducible.  If there is more than one copy of [!p] in
   [s], then this tactic finds the first one which is concatenated on
   the left with anything (irreducible or not), or if there is no such
   occurrence of [!p], then finds the first one overall.  If this [!p]
   is already concatenated on the left with something irreducible,
   then if that something is a [p], it cancels them.  If that
   something is not a [p], then it fails.  *)

Ltac partly_cancel_left_opposite_of_in p s :=
  match s with
    | context cxt [ @concat _ ?trg _ _ (!p) p ] =>
      let mid := context cxt[ idpath trg ] in path_using mid opposite_left_inverse
    | context cxt [ !p @ (?a @ ?b) ] =>
      let mid := context cxt[ (!p @ a) @ b ] in path_using mid concat_associativity
    | context cxt [ !p @ _ ] => fail 1
    | context cxt [ (?a @ !p) @ ?b ] =>
      let mid := context cxt[ a @ (!p @ b) ] in path_using mid concat_associativity
    | context cxt [ ?a @ (?b @ !p) ] =>
      let mid := context cxt[ (a @ b) @ !p ] in path_using mid concat_associativity
  end;
  cancel_units.

(** This tactic simply calls the previous one for the source and the
   target, repeatedly, until it can no longer make progress.
   *)
Ltac cancel_left_opposite_of p :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [
          partly_cancel_left_opposite_of_in p s
        | partly_cancel_left_opposite_of_in p t
      ]
    end
  ).

(** Now the same thing on the right *)

Ltac partly_cancel_right_opposite_of_in p s :=
  match s with
    | context cxt [ @concat _ ?src _ _ p (!p) ] =>
      let mid := context cxt[ idpath src ] in path_using mid opposite_right_inverse
    | context cxt [ (?a @ ?b) @ !p ] =>
      let mid := context cxt[ a @ (b @ !p) ] in path_using mid concat_associativity
    | context cxt [ _ @ !p ] => fail 1
    | context cxt [ ?a @ (!p @ ?b) ] =>
      let mid := context cxt[ (a @ !p) @ b ] in path_using mid concat_associativity
    | context cxt [ (!p @ ?a) @ ?b ] =>
      let mid := context cxt[ !p @ (a @ b) ] in path_using mid concat_associativity
  end;
  cancel_units.

Ltac cancel_right_opposite_of p :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [
          partly_cancel_right_opposite_of_in p s
        | partly_cancel_right_opposite_of_in p t
      ]
    end
  ).

(** This tactic tries to cancel [!p] on both the left and the right. *)
Ltac cancel_opposite_of p :=
  cancel_left_opposite_of p;
  cancel_right_opposite_of p.

(** This tactic looks in [s] for an opposite of anything, and for the
   first one it finds, it tries to cancel it on both sides.  *)
Ltac cancel_opposites_in s :=
  match s with
    context cxt [ !(?p) ] => cancel_opposite_of p
  end.

(** Finally, this tactic repeats the previous one as long as it gets
   us somewhere.  This is most often the easiest of these tactics to
   call in an interactive proof.

   This tactic is not the be-all and end-all of opposite-canceling,
   however; it only works until it runs into an opposite that it can't
   cancel.  It can get stymied by something like [!p @ !q @ q], which
   should simplify to [!p], but the tactic simply tries to cancel
   [!p], makes no progress, and stops.  In such a situation one must
   call [cancel_opposite_of q] directly (or figure out how to write a
   smarter tactic!).  *)

Ltac cancel_opposites :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ cancel_opposites_in s | cancel_opposites_in t ]
    end
  ).

(** Now we have a sequence of fairly boring tactics, each of which
   corresponds to a simple lemma.  Each of these tactics repeatedly
   looks for occurrences, in either the source or target of the goal,
   of something whose form can be changed by the lemma in question,
   then calls [path_using] to change it.

   For each lemma the basic tactic is called [do_LEMMA].  If the lemma
   can sensibly be applied in two directions, there is also an
   [undo_LEMMA] tactic.  *)

(** Tactics for [opposite_opposite] *)

Ltac do_opposite_opposite_in s :=
  match s with
    | context cxt [ ! (! ?p) ] =>
      let mid := context cxt [ p ] in path_using mid opposite_opposite
  end.

Ltac do_opposite_opposite :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ do_opposite_opposite_in s | do_opposite_opposite_in t ]
    end
  ).

(** Tactics for [opposite_map]. *)

Ltac apply_opposite_map :=
  match goal with
    | |- map ?f' (! ?p') = ! map ?f' ?p' =>
      apply opposite_map with (f := f') (p := p')
    | |- ! map ?f' ?p' = map ?f' (! ?p') =>
      apply opposite, opposite_map with (f := f') (p := p')
  end.

Ltac do_opposite_map_in s :=
  match s with
    | context cxt [ map ?f (! ?p) ] =>
      let mid := context cxt [ ! map f p ] in path_using mid opposite_map
  end.

Ltac do_opposite_map :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ do_opposite_map_in s | do_opposite_map_in t ]
    end
  ); do_opposite_opposite.

Ltac undo_opposite_map_in s :=
  match s with
    | context cxt [ ! (map ?f ?p) ] =>
      let mid := context cxt [ map f (! p) ] in path_using mid opposite_map
  end.

Ltac undo_opposite_map :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ undo_opposite_map_in s | undo_opposite_map_in t ]
    end
  ); do_opposite_opposite.

(** Tactics for [opposite_concat]. *)

Ltac do_opposite_concat_in s :=
  match s with
    | context cxt [ (! ?p) @ (! ?q) ] =>
      let mid := context cxt [ ! (q @ p) ] in path_using mid opposite_concat
  end.

Ltac do_opposite_concat :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ do_opposite_concat_in s | do_opposite_concat_in t ]
    end
  ); do_opposite_opposite.

Ltac undo_opposite_concat_in s :=
  match s with
    | context cxt [ ! (?q @ ?p) ] =>
      let mid := context cxt [ (! p) @ (! q) ] in path_using mid opposite_concat
  end.

Ltac undo_opposite_concat :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ undo_opposite_concat_in s | undo_opposite_concat_in t ]
    end
  ); do_opposite_opposite.

(** Tactics for [compose_map].  As with [happly], [apply compose_map]
   often fail to unify, so we define a separate tactic. *)

Ltac apply_compose_map :=
  match goal with
    | |- map (?g' o ?f') ?p' = map ?g' (map ?f' ?p') =>
      apply compose_map with (g := g') (f := f') (p := p')
    | |- map ?g' (map ?f' ?p') = map (?g' o ?f') ?p' =>
      apply opposite; apply compose_map with (g := g') (f := f') (p := p')
  end.

Ltac do_compose_map_in s :=
  match s with
    | context cxt [ map (?f o ?g) ?p ] =>
      let mid := context cxt [ map f (map g p) ] in
        path_via mid; try apply_compose_map
  end.

Ltac do_compose_map :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ do_compose_map_in s | do_compose_map_in t ]
    end
  ).

Ltac undo_compose_map_in s :=
  match s with
    | context cxt [ map ?f (map ?g ?p) ] =>
      let mid := context cxt [ map (f o g) p ] in
        path_via mid; try apply_compose_map
  end.

Ltac undo_compose_map :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ undo_compose_map_in s | undo_compose_map_in t ]
    end
  ).

(** Tactics for [concat_map]. *)

Ltac do_concat_map_in s :=
  match s with
    | context cxt [ map ?f (?p @ ?q) ] =>
      let mid := context cxt [ map f p @ map f q ] in
        path_using mid (concat_map _ _ _ _ _ f p q)
  end.

Ltac do_concat_map :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ do_concat_map_in s | do_concat_map_in t ]
    end
  ).

Ltac undo_concat_map_in s :=
  match s with
    | context cxt [ map ?f ?p @ map ?f ?q ] =>
      let mid := context cxt [ map f (p @ q) ] in
        path_using mid (concat_map _ _ _ _ _ f p q)
  end.

Ltac undo_concat_map :=
  repeat progress (
    match goal with
      |- ?s = ?t => first [ undo_concat_map_in s | undo_concat_map_in t ]
    end
  ).

(** Now we return to proving lemmas about paths.
   We show that homotopies are natural with respect to paths in the domain. *)

Lemma homotopy_naturality {A B} {x y : A} (f g : A -> B) (p : forall x, f x = g x) (q : x = y) :
  map f q @ p y = p x @ map g q.
Proof.
  induction q. instantiate.
  cancel_units.
Defined.

Hint Resolve @homotopy_naturality : path_hints.

Lemma homotopy_naturality_toid {A} {x y : A} (f : A -> A) (p : forall x, f x = x)  (q : x = y) :
  map f q @ p y = p x @ q.
Proof.
  induction q.
  cancel_units.
Defined.

Hint Resolve @homotopy_naturality_toid : path_hints.

Lemma homotopy_naturality_fromid {A} {x y : A} (f : A -> A) (p : forall x, x = f x) (q : x = y) :
  q @ p y = p x @ map f q.
Proof.
  induction q.
  cancel_units.
Defined.

Hint Resolve @homotopy_naturality_fromid : path_hints.

(** Cancellability of concatenation on both sides. *)

Lemma concat_cancel_right {A} {x y z : A} (r : y = z) (p q : x = y)  : (p @ r = q @ r) -> (p = q).
Proof.
  intro a.
  induction r.
  hott_simpl.
Defined.

Lemma concat_cancel_left {A} {x y z : A} (p : x = y) (q r : y = z) : (p @ q = p @ r) -> (q = r).
Proof.
  intro a.
  induction p.
  induction r.
  hott_simpl.
Defined.

(** If a function is homotopic to the identity, then that homotopy
   makes it a "well-pointed" endofunctor in the following sense. *)

Lemma htoid_well_pointed {A} (f : A -> A) (p : forall x, f x = x) (x : A) :
  map f (p x) = p (f x).
Proof.
  apply concat_cancel_right with (r := p x).
  apply homotopy_naturality_toid.
Defined.

(** Mates *)

Lemma concat_moveright_onright {A} {x y z : A} (p : x = z) (q : x = y) (r : z = y) :
  (p = q @ !r) -> (p @ r = q).
Proof.
  intro a.
  path_via (q @ (!r @ r)).
  associate_left.
Defined.

Ltac moveright_onright :=
  match goal with
    | |- (?p @ ?r = ?q) =>
      apply concat_moveright_onright
    | |- (?r = ?q) =>
      path_via (idpath _ @ r); apply concat_moveright_onright
  end; do_opposite_opposite.

Lemma concat_moveleft_onright {A} {x y z : A} (p : x = y) (q : x = z) (r : z = y) :
  (p @ !r = q) -> (p = q @ r).
Proof.
  intro a.
  path_via (p @ (!r @ r)).
  associate_left.
Defined.

Ltac moveleft_onright :=
  match goal with
    | |- (?p = ?q @ ?r) =>
      apply concat_moveleft_onright
    | |- (?p = ?r) =>
      path_via (idpath _ @ r); apply concat_moveleft_onright
  end; do_opposite_opposite.

Lemma concat_moveleft_onleft {A} {x y z : A} (p : y = z) (q : x = z) (r : y = x) :
  (!r @ p = q) -> (p = r @ q).
Proof.
  intro a.
  path_via ((r @ !r) @ p).
  associate_right.
Defined.

Ltac moveleft_onleft :=
  match goal with
    | |- (?p = ?r @ ?q) =>
      apply concat_moveleft_onleft
    | |- (?p = ?r) =>
      path_via (r @ idpath _); apply concat_moveleft_onleft
  end; do_opposite_opposite.

Lemma concat_moveright_onleft {A} {x y z : A} (p : x = z) (q : y = z) (r : y = x) :
  (p = !r @ q) -> (r @ p = q).
Proof.
  intro a.
  path_via ((r @ !r) @ q).
  associate_right.
Defined.

Ltac moveright_onleft :=
  match goal with
    | |- (?r @ ?p = ?q) =>
      apply concat_moveright_onleft
    | |- (?r = ?q) =>
      path_via (r @ idpath _); apply concat_moveright_onleft
  end; do_opposite_opposite.


(* Check that subst uses all equations around *)
Goal forall A (a b c : A), b = a -> b = c -> a = c.
intros.
subst.
reflexivity.
Qed.