Require Import A1_Plan A2_Orientation A4_Droite .
Require Import B1_ClockwiseProp B5_BetweenProp B7_Tactics .
Require Import C1_Distance C3_SumDistance C7_Tactics .
Require Import E4_Tactics .
Require Import F5_Tactics .
Require Import G1_Angles G3_ParticularAngle .
Require Import H1_Triangles .
Require Import I4_Tactics .
Require Import J1_MidLine J2_MidPoint.

Section MIDPOINTandMIDLINE_PROPERTIES.

Lemma ClockwiseAMidLineAMidPoint : forall A B : Point, forall H : A <> B,
	Clockwise A (LineA (MidLine A B H)) (MidPoint A B H).
Proof.
	intros.
	assert (H0 := MidPointBetween A B H).
	assert (H1 := ClockwiseAMidLineAB A B H).
	step8 H0.
Qed.

Lemma ClockwiseMidLineABMidPoint : forall A B : Point, forall H : A <> B,
	Clockwise (LineA (MidLine A B H)) B (MidPoint A B H).
Proof.
	intros.
	assert (H0 := MidPointBetween A B H).
	assert (H1 := ClockwiseAMidLineAB A B H).
	step8 H0.
Qed.

Lemma ClockwiseAMidLineAMidLineB : forall A B : Point, forall H : A <> B,
	Clockwise A (LineA (MidLine A B H)) (LineB (MidLine A B H)).
Proof.
	intros.
	assert (H0 := MidPointBetweenMidLine A B H).
	assert (H1 := ClockwiseAMidLineAMidPoint A B H).
	step8 H0.
Qed.

Lemma ClockwiseBMidLineBMidLineA : forall A B : Point, forall H : A <> B,
	Clockwise B (LineB (MidLine A B H)) (LineA (MidLine A B H)).
Proof.
	intros.
	assert (H0 := MidPointBetweenMidLine A B H).
	assert (H1 := MidPointBetween A B H).
	assert (H2 := ClockwiseAMidLineAB A B H).
	step8 H0.
	right; step8 H1.
Qed.

Lemma EqDistanceOnMidLine : forall A B : Point, forall H : A <> B,
forall M : Point, Distance M A = Distance M B ->
	OnLine (MidLine A B H) M.
Proof.
	intros.
	assert (H1 := ClockwiseBMidLineBMidLineA A B H).
	assert (H2 := ClockwiseAMidLineAMidLineB A B H).
	pose (C := LineA (MidLine A B H)); fold C in H1, H2.
	pose (D := LineB (MidLine A B H)); fold D in H1, H2.
	by3Cases1 C D M.
	 setFourPointsInter4 C D M B ipattern:(E).
	   elim (ClockwiseNotClockwise _ _ _ H3).
	   apply ClockwiseBCA; apply (TwoSidesLine A E).
	  immediate8.
	  immediate8.
	  assert (H7 := OnMidLineEqDistance A B H E H5).
	    apply SegmentBetween.
	   apply ChaslesRec.
	     replace (Distance A M) with (Distance B M).
	    replace (Distance A E) with (Distance B E).
	     usingChasles2 B E M.
	     immediate8.
	    immediate8.
	   step8 H7.
	   immediate8.
	 setFourPointsInter4 C D A M ipattern:(E).
	   elim (ClockwiseNotClockwise _ _ _ H4).
	   apply ClockwiseBCA; apply (TwoSidesLine B E).
	  immediate8.
	  immediate8.
	  assert (H7 := OnMidLineEqDistance A B H E H5).
	    apply SegmentBetween.
	   apply ChaslesRec.
	     replace (Distance B M) with (Distance A M).
	    replace (Distance B E) with (Distance A E).
	     usingChasles2 A E M.
	     immediate8.
	    immediate8.
	   step8 H7.
	   immediate8.
	 immediate8.
Qed.

Lemma UniqueMidPoint : forall (A B : Point) (H : A <> B) (J : Point),
	Collinear A B J -> Distance A J = Distance B J -> J = MidPoint A B H.
Proof.
	intros; unfold MidPoint in |- *.
	byDefEqPoint5.
	assert (H2 : OnLine (MidLine A B H) J).
	 apply EqDistanceOnMidLine; immediate8.
	 immediate8.
Qed.

Lemma MidPointRefl : forall A B : Point, forall H : A <> B, forall H' : A <> B,
	MidPoint A B H = MidPoint A B H'.
Proof.
	intros; apply UniqueMidPoint.
	 apply MidPointCollinearAB.
	 assert (H0 := MidPointEqDistance A B H); immediate8.
Qed.

Lemma MidPointSym : forall A B : Point, forall H : A <> B, forall H' : B <> A,
	MidPoint A B H = MidPoint B A H'.
Proof.
	intros; apply UniqueMidPoint.
	 assert (H0 := MidPointCollinearAB A B H); immediate8.
	 assert (H0 := MidPointEqDistance A B H); immediate8.
Qed.

Lemma MidPointUuuUOo : Oo = MidPoint Uu uU DistinctUuuU.
Proof.
	apply UniqueMidPoint.
	 assert (H := BetweenUuOouU); immediate8.
	 assert (H := DistanceOouU); immediate8.
Qed.

Lemma EquiOrientedMidLineClockwiseAB : forall A B M : Point, forall Hab : A <> B,
	EquiOriented (LineA (MidLine A B Hab)) (LineB (MidLine A B Hab)) (MidPoint A B Hab)  M ->
	Clockwise A B M.
Proof.
	intros.
	assert (H0 := MidPointBetween A B Hab).
	step8 H0.
	right; step8 H.
	 assert (H1 := MidPointOnMidLine A B Hab);  immediate8.
	 assert (H2 := ClockwiseBMidLineBMidLineA A B Hab); immediate8.
Qed.

Lemma EquiOrientedMidLineClockwiseBA : forall A B M : Point, forall Hab : A <> B,
	EquiOriented (LineB (MidLine A B Hab)) (LineA (MidLine A B Hab)) (MidPoint A B Hab)  M ->
	Clockwise A M B.
Proof.
	intros.
	assert (H0 := MidPointBetween A B Hab).
	step8 H0.
	left; step8 H.
	assert (H2 := ClockwiseBMidLineBMidLineA A B Hab); immediate8.
Qed.

Lemma TCongruentAIA'BIA' : forall A B : Point, forall Hab : A <> B,
	TCongruent (Tr A (MidPoint A B Hab) (LineA (MidLine A B Hab))) (Tr  B (MidPoint A B Hab) (LineA (MidLine A B Hab))) .
Proof.
	intros; step8 1.
	 assert (H := MidPointEqDistance A B Hab); immediate8.
	 assert (H := EquilateralAMidLineAB A B Hab); immediate8.
Qed.

Lemma TCongruentAIB'BIB' : forall A B : Point, forall Hab : A <> B,
	TCongruent  (Tr A (MidPoint A B Hab) (LineB (MidLine A B Hab)))  (Tr  B (MidPoint A B Hab) (LineB (MidLine A B Hab))) .
Proof.
	intros; step8 1.
	 assert (H := MidPointEqDistance A B Hab); immediate8.
	 assert (H := EquilateralBMidLineBA A B Hab); immediate8.
Qed.

Lemma TCongruentAIA'AIB' : forall A B : Point, forall Hab : A <> B,
	TCongruent  (Tr A (MidPoint A B Hab) (LineA (MidLine A B Hab)) )  (Tr A (MidPoint A B Hab) (LineB (MidLine A B Hab))) .
Proof.
	intros.
	assert  (TCongruent (Tr A (LineA (MidLine A B Hab)) B)  (Tr A (LineB (MidLine A B Hab)) B)).
	 step8 1.
	  step8 (Distance A B).
	   assert (H := EquilateralAMidLineAB A B Hab); immediate8.
	   assert (H := EquilateralBMidLineBA A B Hab); immediate8.
	  step8 (Distance A B).
	   assert (H := EquilateralAMidLineAB A B Hab); immediate8.
	   assert (H := EquilateralBMidLineBA A B Hab); immediate8.
	 assert (H0 := MidPointBetween A B Hab).
	   step8 2.
	  step8 H.
	  assert (CongruentAngle (LineA (MidLine A B Hab)) A (MidPoint A B Hab)  (LineA (MidLine A B Hab)) A B).
	   step8 H0.
	     assert (H1 := ClockwiseAMidLineAB A B Hab); immediate8.
	   step8 H1.
	     assert  (CongruentAngle (LineB (MidLine A B Hab)) A (MidPoint A B Hab)  (LineB (MidLine A B Hab)) A B).
	    step8 H0.
	      assert (H2 := ClockwiseBMidLineBA A B Hab); immediate8.
	    step8 H2.
	      step8 H.
Qed.

Lemma TCongruentBIA'BIB' : forall A B : Point, forall Hab : A <> B,
	TCongruent  (Tr B (MidPoint A B Hab) (LineA (MidLine A B Hab)) )  (Tr B (MidPoint A B Hab) (LineB (MidLine A B Hab))) .
Proof.
	intros.
	assert (H := TCongruentAIA'BIA' A B Hab).
	step8 H.
	assert (H0 := TCongruentAIB'BIB' A B Hab).
	step8 H0.
	apply TCongruentAIA'AIB'.
Qed.

End MIDPOINTandMIDLINE_PROPERTIES.


(* THIS FILE CONTAINS
   Lemmas that DO NOT depend on CompCert or Verifiable C,
   and that are used in the proof of the C program but are not
   used in the proof of functional_prog.v.
*)

Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import List. Import ListNotations.
Require Import sha.general_lemmas.
Require Import sha.SHA256.
Require Import VST.msl.Coqlib2.
Require Import VST.floyd.coqlib3.
Require Import VST.zlist.sublist.
Require Export sha.common_lemmas.
Require Import Lia.

Global Opaque CBLOCKz LBLOCKz.

Lemma Zlength_intlist_to_bytelist:
  forall l : list int,
       Zlength (intlist_to_bytelist l) = (Zlength l * 4)%Z.
Proof.
intros.
repeat rewrite Zlength_correct. rewrite length_intlist_to_bytelist.
rewrite Nat2Z.inj_mul. rewrite Z.mul_comm. reflexivity.
Qed.

#[export] Hint Rewrite Zlength_intlist_to_bytelist : sublist.
#[export] Hint Rewrite Zlength_intlist_to_bytelist : Zlength.

Lemma skipn_intlist_to_bytelist:
  forall i m, skipn (4*i) (intlist_to_bytelist m) = intlist_to_bytelist (skipn i m).
Proof.
induction i; intros.
reflexivity.
replace (4 * S i)%nat with (4 + 4 * i)%nat by lia.
destruct m; try reflexivity.
apply IHi.
Qed.

Lemma firstn_intlist_to_bytelist:
  forall i m, firstn (4*i) (intlist_to_bytelist m) = intlist_to_bytelist (firstn i m).
Proof.
induction i; intros.
reflexivity.
replace (4 * S i)%nat with (4 + 4 * i)%nat by lia.
destruct m; try reflexivity.
simpl. f_equal. f_equal. f_equal. f_equal.
apply IHi.
Qed.

Lemma sublist_intlist_to_bytelist:
 forall i j m,
  sublist (i * WORD) (j * WORD) (intlist_to_bytelist m) =
  intlist_to_bytelist (sublist i j m).
Proof.
intros.
unfold sublist.
change WORD with 4.
destruct (zlt j 0).
rewrite (Z2Nat_neg _ l).
rewrite (Z2Nat_neg (j*4)) by lia.
rewrite !skipn_nil.
reflexivity.
rewrite ?(Z.mul_comm _ 4).
rewrite (Z2Nat.inj_mul 4 j) by lia.
change (Z.to_nat 4) with 4%nat.
rewrite -> firstn_intlist_to_bytelist.
destruct (zlt i 0).
rewrite (Z2Nat_neg _ l).
rewrite (Z2Nat_neg (4*i)) by lia.
reflexivity.
rewrite ?Z2Nat.inj_mul by lia.
change (Z.to_nat 4) with 4%nat.
apply skipn_intlist_to_bytelist.
Qed.

Lemma bytelist_to_intlist_to_bytelist':
  forall nl: list byte,
  Nat.divide (Z.to_nat WORD) (length nl) ->
  intlist_to_bytelist (bytelist_to_intlist nl) = nl.
Proof.
intros nl [k H].
revert nl H; induction k; intros.
destruct nl; inv H; reflexivity.
simpl in H.
destruct nl as [ | a [ | b [ | c [ | d ?]]]]; inv H.
unfold bytelist_to_intlist; fold bytelist_to_intlist.
rewrite intlist_to_bytelist_bytes_to_int_cons by auto.
repeat f_equal; auto.
Qed.

Lemma Ndivide_Zdivide_length:
  forall {A} n (al: list A),
   0 <= n ->
   (Nat.divide (Z.to_nat n) (length al) <->
    (n | Zlength al)).
Proof.
intros; split; intros [i ?].
exists (Z.of_nat i). rewrite Zlength_correct, H0.
rewrite Nat2Z.inj_mul.
rewrite Z2Nat.id; auto.
exists (Z.to_nat i).
rewrite Zlength_correct in H0.
destruct (zeq n 0). subst.
simpl. rewrite Z.mul_0_r in H0. destruct al; inv H0.
rewrite mult_0_r. reflexivity.
assert (0 <= i).
assert (0 <= i * n) by lia.
apply Z.mul_nonneg_cancel_r in H1; auto; lia.
rewrite <- (Z2Nat.id (i*n)%Z) in H0 by lia.
apply Nat2Z.inj in H0. rewrite H0.
rewrite Z2Nat.inj_mul; auto.
Qed.

Lemma bytelist_to_intlist_to_bytelist:
  forall nl: list byte,
  Z.divide WORD (Zlength nl) ->
  intlist_to_bytelist (bytelist_to_intlist nl) = nl.
Proof.
intros.
apply bytelist_to_intlist_to_bytelist'; auto.
apply Ndivide_Zdivide_length; auto.
compute; congruence.
Qed.

Lemma length_bytelist_to_intlist: forall n l,
       length l = (Z.to_nat WORD * n)%nat ->
       length (bytelist_to_intlist l) = n.
Proof.
induction n; intros.
destruct l; inv H; reflexivity.
replace (S n) with (1 + n)%nat in H by lia.
rewrite mult_plus_distr_l in H.
destruct l as [|i0 l]; [ inv H |].
destruct l as [|i1 l]; [ inv H |].
destruct l as [|i2 l]; [ inv H |].
destruct l as [|i3 l]; [ inv H |].
simpl. f_equal. apply IHn. forget (Z.to_nat WORD * n)%nat as A. inv H; auto.
Qed.

Lemma big_endian_integer4:
 forall c0 c1 c2 c3,
  big_endian_integer (c0::c1::c2::c3::nil) =
  Int.or (Int.shl (Int.repr (Byte.unsigned c0)) (Int.repr 24))
     (Int.or (Int.shl (Int.repr (Byte.unsigned c1)) (Int.repr 16))
   (Int.or (Int.shl (Int.repr (Byte.unsigned c2)) (Int.repr 8))
          (Int.repr (Byte.unsigned c3)))).
Proof.
intros.
unfold big_endian_integer.
simpl.
apply Int.same_bits_eq; intros.
assert (Int.zwordsize=32) by reflexivity.
assert (32 < Int.max_unsigned) by (compute; auto).
autorewrite with testbit.
if_tac; simpl; auto;  try lia.
if_tac; simpl; auto; try lia.
if_tac; simpl; auto; try lia.
if_tac; simpl; auto; try lia.
if_tac; simpl; auto; try lia.
autorewrite with testbit; auto.
autorewrite with testbit; auto.
replace (i - 8 - 8) with (i-16) by lia.
rewrite orb_assoc. auto.
if_tac; simpl; auto; try lia.
autorewrite with testbit; auto.
replace (i - 8 - 8) with (i-16) by lia.
replace (i - 16 - 8) with (i-24) by lia.
repeat rewrite orb_assoc. auto.
Qed.

Local Open Scope nat.

Definition LBLOCK : nat := Z.to_nat LBLOCKz.
Definition CBLOCK : nat := Z.to_nat CBLOCKz.
Opaque LBLOCK CBLOCK.

Lemma LBLOCK_zeq: Z.of_nat LBLOCK = 16%Z.
Proof. reflexivity. Qed.

Lemma CBLOCK_zeq: (Z.of_nat CBLOCK = 64%Z).
Proof. reflexivity. Qed.

Lemma LBLOCKz_nonneg: (0 <= LBLOCKz)%Z.
Proof. change LBLOCKz with 16%Z; lia. Qed.
#[export] Hint Resolve LBLOCKz_nonneg : core.

Lemma LBLOCKz_pos: (0 < LBLOCKz)%Z.
Proof. change LBLOCKz with 16%Z; lia. Qed.
#[export] Hint Resolve LBLOCKz_pos : core.

Lemma CBLOCKz_nonneg: (0 <= CBLOCKz)%Z.
Proof. change CBLOCKz with 64%Z; lia. Qed.
#[export] Hint Resolve CBLOCKz_nonneg : core.

Lemma CBLOCKz_pos: (0 < CBLOCKz)%Z.
Proof. change CBLOCKz with 64%Z; lia. Qed.
#[export] Hint Resolve CBLOCKz_pos : core.

Local Open Scope Z.

Lemma divide_hashed:
 forall (bb: list int),
    Nat.divide LBLOCK (length bb) <->
    (LBLOCKz | Zlength bb).
Proof.
intros.
change LBLOCK with (Z.to_nat LBLOCKz).
apply Ndivide_Zdivide_length.
auto.
Qed.

Lemma hash_blocks_equation' : forall (r : registers) (msg : list int),
       hash_blocks r msg =
       match msg with
       | [] => r
       | _ :: _ => hash_blocks (hash_block r (firstn LBLOCK msg)) (skipn LBLOCK msg)
       end.
Proof. exact hash_blocks_equation. Qed.

Lemma CBLOCK_eq: CBLOCK=64%nat.
Proof. reflexivity. Qed.
Lemma LBLOCK_eq: LBLOCK=16%nat.
Proof. reflexivity. Qed.

Lemma hash_blocks_last:
 forall a bl c,
              Zlength a = 8 ->
              (LBLOCKz | Zlength bl) ->
              Zlength c = LBLOCKz ->
   hash_block (hash_blocks a bl) c = hash_blocks a (bl++ c).
Proof.
intros.
assert (POS: (0 < LBLOCK)%nat) by (rewrite LBLOCK_eq; lia).
apply divide_hashed in H0.
destruct H0 as [n ?].
rewrite Zlength_correct in H,H1.
change 8 with (Z.of_nat 8) in H.
change LBLOCKz with (Z.of_nat LBLOCK) in H1.
apply Nat2Z.inj in H.
apply Nat2Z.inj in H1.
revert a bl H H0; induction n; intros.
destruct bl; inv H0.
rewrite hash_blocks_equation'.
simpl. rewrite hash_blocks_equation'.
destruct c eqn:?. inv H1.
rewrite <- Heql in *; clear i l Heql.
rewrite firstn_same by lia.
replace (skipn LBLOCK c) with (@nil int).
rewrite hash_blocks_equation'; reflexivity.
pose proof (skipn_length c LBLOCK).
rewrite H1 in H0.
destruct (skipn LBLOCK c); try reflexivity; inv H0.
replace (S n * LBLOCK)%nat with (n * LBLOCK + LBLOCK)%nat  in H0 by
  (simpl; lia).
rewrite hash_blocks_equation'.
destruct bl.
simpl in H0.
Psatz.lia.
forget (i::bl) as bl'; clear i bl. rename bl' into bl.
rewrite IHn.
symmetry.
rewrite hash_blocks_equation.
destruct bl.
simpl in H0; Psatz.lia.
unfold app at 1; fold app.
forget (i::bl) as bl'; clear i bl. rename bl' into bl.
f_equal.
f_equal.
apply firstn_app1.
Psatz.nia.
apply skipn_app1.
Psatz.nia.
apply length_hash_block; auto. (* fixme *) change 16%nat with LBLOCK.
rewrite firstn_length. apply min_l.
Psatz.nia.
rewrite skipn_length.
lia.
Qed.

Lemma length_hash_blocks: forall regs blocks,
  length regs = 8%nat ->
  (LBLOCKz | Zlength blocks) ->
  length (hash_blocks regs blocks) = 8%nat.
Proof.
intros.
destruct H0 as [n ?].
rewrite Zlength_correct in H0.
assert (POS := LBLOCKz_pos).
change LBLOCKz with (Z.of_nat LBLOCK) in *.
rewrite <- (Z2Nat.id n) in H0
 by (apply -> Z.mul_nonneg_cancel_r ; [ | apply POS]; lia).
rewrite <- Nat2Z.inj_mul in H0.
apply Nat2Z.inj in H0.
revert regs blocks H H0; induction (Z.to_nat n); intros.
  destruct blocks; inv H0.
rewrite hash_blocks_equation'; auto.
destruct blocks.
destruct LBLOCK; inv POS; inv H0.
rewrite hash_blocks_equation'; auto.
forget (i::blocks) as bb.
apply IHn0; auto.
apply length_hash_block; auto. (* fixme *) change 16%nat with LBLOCK.
rewrite firstn_length. nia.
rewrite skipn_length. nia.
Qed.

Theorem Zmod_mod_mult :
  forall n a b, (0 < a)%Z -> (0 <= b)%Z ->
  Zmod (Zmod n (a * b)) b = Zmod n b.
Proof.
intros n a [|b|b] Ha Hb.
rewrite ?Z.mul_0_r.
now rewrite 2!Zmod_0_r.
rewrite (Zmod_eq n (a * Zpos b)).
rewrite Zmult_assoc.
unfold Zminus.
rewrite Zopp_mult_distr_l.
apply Z_mod_plus.
easy.
apply Zmult_gt_0_compat.
now apply Z.lt_gt.
easy.
now elim Hb.
Qed.

Lemma generate_and_pad_lemma1:
  forall hashed (dd: list byte) hashed' (dd': list byte) pad bitlen
   (PAD : pad = 0 \/ dd' = [])
   (H0 : Zlength dd' + 8 <= CBLOCKz)
   (H1 : 0 <= pad < 8)
   (H4: (LBLOCKz | Zlength hashed))
   (H7 : ((Zlength hashed * 4 + Zlength dd) * 8)%Z = bitlen)
   (H3: Zlength dd < CBLOCKz)
   (H2 : (LBLOCKz | Zlength hashed'))
   (H5 : intlist_to_bytelist hashed' ++ dd' =
     intlist_to_bytelist hashed ++ dd ++ [Byte.repr 128] ++ repeat Byte.zero (Z.to_nat pad)),
   let lastblock :=
               (dd' ++
                repeat Byte.zero (Z.to_nat (CBLOCKz - 8 - Zlength dd')) ++
                intlist_to_bytelist [hi_part bitlen; lo_part bitlen])
   in let lastblock' :=
             bytelist_to_intlist lastblock
   in forall (H99: Zlength lastblock = CBLOCKz),
 generate_and_pad (intlist_to_bytelist hashed ++ dd) = hashed' ++ lastblock'.
Proof.
intros.
apply intlist_to_bytelist_inj.
rewrite intlist_to_bytelist_app.
unfold lastblock'.
rewrite bytelist_to_intlist_to_bytelist; auto.
2: rewrite H99; exists LBLOCKz; reflexivity.
unfold lastblock.
rewrite <- app_ass. rewrite H5.
unfold generate_and_pad.
rewrite intlist_to_bytelist_app.
rewrite bytelist_to_intlist_to_bytelist; auto.
*
repeat rewrite app_ass.
f_equal. f_equal. f_equal.
rewrite <- app_ass.
f_equal.
rewrite <- repeat_app.
f_equal.
clear - H5 H2 H1 H0 PAD.
assert (Zlength dd' <= 56) by (change CBLOCKz with 64 in H0; lia).
clear H0.
replace (Zlength (intlist_to_bytelist hashed ++ dd))
  with (4*Zlength hashed' + Zlength dd' - (1+pad)).
2:{
rewrite Z.mul_comm.
rewrite <-  Zlength_intlist_to_bytelist.
rewrite <- Zlength_app.
rewrite H5.
rewrite <- app_ass.
rewrite Zlength_app.
forget (Zlength (intlist_to_bytelist hashed ++ dd)) as B.
rewrite Zlength_app.
rewrite Zlength_cons, Zlength_nil, Zlength_correct.
rewrite repeat_length. rewrite Z2Nat.id by lia. lia.
}
change (Z.of_nat CBLOCK - 8) with 56.
clear H5.
rewrite <- Z2Nat.inj_add by (change CBLOCKz with 64; lia).
f_equal. {
 transitivity (- (4 * Zlength hashed' + (Zlength dd' - (1 + pad) + 9)) mod 64).
 f_equal. f_equal. lia.
 rewrite <- Z.sub_0_l.
 rewrite Zminus_mod.
 rewrite Zplus_mod.
 rewrite Z.mul_comm.
 destruct H2 as [a H2]; rewrite H2.
 rewrite <- Z.mul_assoc.
 change (LBLOCKz * 4)%Z with 64%Z.
 rewrite Zmult_mod.
 assert (64<>0) by (clear; lia).
 rewrite Z.mod_same by auto. rewrite Z.mul_0_r.
 rewrite Z.mod_0_l at 2 by auto.
 rewrite Z.add_0_l. rewrite Z.mod_mod by auto.
 replace (0 mod 64) with (64 mod 64) by reflexivity.
 change CBLOCKz with 64. change LBLOCKz with 16 in H2.
 destruct PAD; subst.
 rewrite <- Zminus_mod.
 rewrite Z.mod_small; try lia.
 rewrite Zlength_correct in H|-*; lia.
 rewrite Zlength_nil in *.
 rewrite <- Zminus_mod.
 rewrite Z.mod_small; lia.
}
 rewrite Zlength_app, Zlength_intlist_to_bytelist.
 rewrite H7.
 reflexivity.
*
 autorewrite with sublist.
 rewrite Zlength_repeat by (apply Z_mod_lt; compute; auto).
 forget ( Zlength hashed * 4 + Zlength dd) as d.
 change (Z.succ 0) with 1.
 change WORD with 4.
 rewrite Z.add_assoc.
 replace (d + 9) with (d + 1 + 8) by lia.
 forget (d+1) as e.
 apply Zmod_divide; try lia.
 clear.
 rewrite Zplus_mod.
 change 64 with (16*4)%Z.
 rewrite Zmod_mod_mult by lia.
 rewrite <- Z.sub_0_l.
 rewrite Zminus_mod.
 rewrite (Zplus_mod e 8).
 change (0 mod 4) with (4 mod 4).
 change (8 mod 4) with 0.
 rewrite Z.add_0_r.
  rewrite <- Zminus_mod.
  rewrite <- Zplus_mod.
 replace (e + (4 - e mod 4)) with (4 + (e - e mod 4)) by lia.
 rewrite Zplus_mod. rewrite Z.mod_same by lia.
 rewrite Zminus_mod.   rewrite Z.mod_mod by lia.
 rewrite Z.sub_diag. reflexivity.
Qed.


Require Import coqutil.Decidable.
Require Coq.NArith.BinNatDef.

Require Export Coq.Strings.String.

Module Ascii.
  Definition ltb (c d : Ascii.ascii) : bool := BinNatDef.N.ltb (Ascii.N_of_ascii c) (Ascii.N_of_ascii d).

  Lemma ltb_antirefl : forall k, ltb k k = false.
  Proof. cbv [ltb]; intro; apply BinNat.N.ltb_irrefl. Qed.

  Lemma ltb_trans : forall k1 k2 k3, ltb k1 k2 = true -> ltb k2 k3 = true -> ltb k1 k3 = true.
  Proof.
    cbv [ltb]; intros *; rewrite !BinNat.N.ltb_lt; intros; etransitivity; eassumption.
  Qed.

  Lemma ltb_total : forall k1 k2, ltb k1 k2 = false -> ltb k2 k1 = false -> k1 = k2.
  Proof.
    cbv [ltb]; intros k1 k2; rewrite !BinNat.N.ltb_ge; intros.
    rewrite <- (Ascii.ascii_N_embedding k1), <- (Ascii.ascii_N_embedding k2); apply f_equal.
    apply BinNat.N.le_antisymm; assumption.
  Qed.
End Ascii.

Fixpoint ltb (a b : string) : bool :=
  match a, b with
    | EmptyString, String _ _ => true
    | String x a', String y b' =>
      if Ascii.eqb x y
      then ltb a' b'
      else Ascii.ltb x y
    | _, _ => false
  end.

Local Ltac strict_order_t :=
  cbn [ltb];
  repeat first [ reflexivity
               | congruence
               | progress subst
               | rewrite Ascii.eqb_refl in *
               | rewrite Ascii.ltb_antirefl in *
               | match goal with
                 | [ H : ?x = false |- context[?x] ] => rewrite H
                 | [ |- context[if Ascii.eqb ?x ?y then _ else _] ] => destruct (Ascii.eqb_spec x y)
                 | [ H1 : Ascii.ltb ?x ?y = true, H2 : Ascii.ltb ?y ?x = true |- _ ]
                   => exfalso;
                      clear -H1 H2;
                      assert (Ascii.ltb x x = true) by (eapply Ascii.ltb_trans; eassumption);
                      clear H1 H2
                 | [ H1 : Ascii.ltb ?x ?y = false, H2 : Ascii.ltb ?y ?x = false |- _ ]
                   => assert (x = y) by (apply Ascii.ltb_total; assumption);
                      clear H1 H2
                 | [ |- String _ _ = String _ _ ] => apply f_equal2
                 end
               | progress intros
               | solve [ eauto using Ascii.ltb_trans with nocore ] ].

Lemma ltb_antirefl : forall k, ltb k k = false.
Proof. induction k; strict_order_t. Qed.

Lemma ltb_trans : forall k1 k2 k3, ltb k1 k2 = true -> ltb k2 k3 = true -> ltb k1 k3 = true.
Proof. induction k1, k2, k3; strict_order_t. Qed.

Lemma ltb_total : forall k1 k2, ltb k1 k2 = false -> ltb k2 k1 = false -> k1 = k2.
Proof. induction k1, k2; strict_order_t. Qed.

#[global] Instance eqb_spec: EqDecider eqb.
Proof.
  intros. destruct (x =? y)%string eqn: E; constructor.
  - apply eqb_eq. assumption.
  - apply eqb_neq. assumption.
Qed.


Require Import LiterateCoq.Tactics.
Require Import Compiler.
Require Import ZArith.

Lemma list_pointless_split : forall A B:Type, forall l : list A, forall x : B,
        match l with | nil => x | (_ :: _)%list => x end = x.
Proof.
  destruct l; eauto.
Qed.
Lemma list_pointless_split' : forall A B:Type, forall l : list A, forall x : B,
        match l with | nil => x | (_ :: nil)%list => x | (_ :: _ :: _)%list => x end = x.
Proof.
  destruct l; intros; eauto. destruct l; eauto.
Qed.

Lemma eval_step : forall a : Arith, forall s : list Num.Int, forall xs : list StackOp,
        eval s (compile a ++ xs) = eval (eval' a :: s) xs.
Proof.
  hint_rewrite List.app_assoc_reverse.
  hint_rewrite list_pointless_split, list_pointless_split'.

  induction a; intros; simpl; iauto;

    hint_rewrite IHa1, IHa2; iauto'.
Qed.

Lemma compiler_correctness' : forall a : Arith, forall s : list Num.Int,
      eval s (compile a) = Data.Either.Right (eval' a).
Proof.
  hint_rewrite eval_step.
  hint_rewrite list_pointless_split, list_pointless_split'.

  induction a; intros; simpl; hint_simpl; iauto'.
Qed.

Theorem compiler_correctness : forall a : Arith, eval nil (compile a) = Data.Either.Right (eval' a).
Proof.
  hint compiler_correctness'.
  intros; iauto.
Qed.


Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Strings.Ascii Coq.Strings.String.
Require Import Coq.Arith.Arith.
Require Import Coq.NArith.NArith.
Require Import Coq.Structures.OrderedType.
Require Export Crypto.Util.FixCoqMistakes.

(** This is copied verbatim from coq/theories/Structures/OrderedTypeEx.v, and should be removed once we bump the version requirement to 8.12, where we get the benefit of https://github.com/coq/coq/pull/12044 *)
(** See the original file in the Coq sources for the license *)

Module Ascii_as_OT <: UsualOrderedType.
  Definition t := ascii.

  Definition eq := @eq ascii.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Definition cmp (a b : ascii) : comparison :=
    N.compare (N_of_ascii a) (N_of_ascii b).

  Lemma cmp_eq (a b : ascii):
    cmp a b = Eq  <->  a = b.
  Proof.
    unfold cmp.
    rewrite N.compare_eq_iff.
    split. 2:{ intro. now subst. }
    intro H.
    rewrite<- (ascii_N_embedding a).
    rewrite<- (ascii_N_embedding b).
    now rewrite H.
  Qed.

  Lemma cmp_lt_nat (a b : ascii):
    cmp a b = Lt  <->  (nat_of_ascii a < nat_of_ascii b)%nat.
  Proof.
    unfold cmp. unfold nat_of_ascii.
    rewrite N2Nat.inj_compare.
    rewrite Nat.compare_lt_iff.
    reflexivity.
  Qed.

  Lemma cmp_antisym (a b : ascii):
    cmp a b = CompOpp (cmp b a).
  Proof.
    unfold cmp.
    apply N.compare_antisym.
  Qed.

  Definition lt (x y : ascii) := (N_of_ascii x < N_of_ascii y)%N.

  Lemma lt_trans (x y z : ascii):
    lt x y -> lt y z -> lt x z.
  Proof.
    apply N.lt_trans.
  Qed.

  Lemma lt_not_eq (x y : ascii):
     lt x y -> x <> y.
  Proof.
    intros L H. subst.
    exact (N.lt_irrefl _ L).
  Qed.

  Local Lemma compare_helper_eq {a b : ascii} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Local Lemma compare_helper_gt {a b : ascii} (G : cmp a b = Gt):
    lt b a.
  Proof.
    now apply N.compare_gt_iff.
  Qed.

  Definition compare (a b : ascii) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT E
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : ascii): {x = y} + { ~ (x = y)} := ascii_dec x y.
End Ascii_as_OT.

(** [String] is an ordered type with respect to the usual lexical order. *)

Module String_as_OT <: UsualOrderedType.

  Definition t := string.

  Definition eq := @eq string.
  Definition eq_refl := @eq_refl t.
  Definition eq_sym := @eq_sym t.
  Definition eq_trans := @eq_trans t.

  Inductive lts : string -> string -> Prop :=
    | lts_empty : forall a s, lts EmptyString (String a s)
    | lts_tail : forall a s1 s2, lts s1 s2 -> lts (String a s1) (String a s2)
    | lts_head : forall (a b : ascii) s1 s2,
        lt (nat_of_ascii a) (nat_of_ascii b) ->
        lts (String a s1) (String b s2).

  Definition lt := lts.

  Lemma nat_of_ascii_inverse a b : nat_of_ascii a = nat_of_ascii b -> a = b.
  Proof.
    intro H.
    rewrite <- (ascii_nat_embedding a).
    rewrite <- (ascii_nat_embedding b).
    apply f_equal; auto.
  Qed.

  Lemma lts_tail_unique a s1 s2 : lt (String a s1) (String a s2) ->
    lt s1 s2.
  Proof.
    intro H; inversion H; subst; auto.
    remember (nat_of_ascii a) as x.
    apply lt_irrefl in H1; inversion H1.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    induction x; intros y z H1 H2.
    - destruct y as [| b y']; inversion H1.
      destruct z as [| c z']; inversion H2; constructor.
    - destruct y as [| b y']; inversion H1; subst;
        destruct z as [| c z']; inversion H2; subst.
      + constructor. eapply IHx; eauto.
      + constructor; assumption.
      + constructor; assumption.
      + constructor. eapply lt_trans; eassumption.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    induction x; intros y LT.
    - inversion LT. intro. inversion H.
    - inversion LT; subst; intros EQ.
      * specialize (IHx s2 H2).
        inversion EQ; subst; auto.
        apply IHx; unfold eq; auto.
      * inversion EQ; subst; auto.
        apply Nat.lt_irrefl in H2; auto.
  Qed.

  Fixpoint cmp (a b : string) : comparison :=
    match a, b with
    | EmptyString, EmptyString => Eq
    | EmptyString, _ => Lt
    | String _ _, EmptyString => Gt
    | String a_head a_tail, String b_head b_tail =>
      match Ascii_as_OT.cmp a_head b_head with
      | Lt => Lt
      | Gt => Gt
      | Eq => cmp a_tail b_tail
      end
    end.

  Lemma cmp_eq (a b : string):
    cmp a b = Eq  <->  a = b.
  Proof.
    revert b.
    induction a, b; try easy.
    cbn.
    remember (Ascii_as_OT.cmp _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; try discriminate;
      try rewrite Ascii_as_OT.cmp_eq in Heqc; try subst;
      try rewrite IHa; intro H.
    { now subst. }
    { now inversion H. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
    { inversion H; subst. rewrite<- Heqc. now rewrite Ascii_as_OT.cmp_eq. }
  Qed.

  Lemma cmp_antisym (a b : string):
    cmp a b = CompOpp (cmp b a).
  Proof.
    revert b.
    induction a, b; try easy.
    cbn. rewrite IHa. clear IHa.
    remember (Ascii_as_OT.cmp _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; rewrite Ascii_as_OT.cmp_antisym in Heqc;
      destruct Ascii_as_OT.cmp; cbn in *; easy.
  Qed.

  Lemma cmp_lt (a b : string):
    cmp a b = Lt  <->  lt a b.
  Proof.
    revert b.
    induction a as [ | a_head a_tail ], b; try easy; cbn.
    { split; trivial. intro. apply lts_empty. }
    remember (Ascii_as_OT.cmp _ _) as c eqn:Heqc. symmetry in Heqc.
    destruct c; split; intro H; try discriminate; trivial.
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      apply String_as_OT.lts_tail.
      apply IHa_tail.
      assumption.
    }
    {
      rewrite Ascii_as_OT.cmp_eq in Heqc. subst.
      inversion H; subst. { rewrite IHa_tail. assumption. }
      exfalso. apply (Nat.lt_irrefl (nat_of_ascii a)). assumption.
    }
    {
      apply String_as_OT.lts_head.
      rewrite<- Ascii_as_OT.cmp_lt_nat.
      assumption.
    }
    {
      exfalso. inversion H; subst.
      {
         assert(X: Ascii_as_OT.cmp a a = Eq). { apply Ascii_as_OT.cmp_eq. trivial. }
         rewrite Heqc in X. discriminate.
      }
      rewrite<- Ascii_as_OT.cmp_lt_nat in *. rewrite Heqc in *. discriminate.
    }
  Qed.

  Local Lemma compare_helper_lt {a b : string} (L : cmp a b = Lt):
    lt a b.
  Proof.
    now apply cmp_lt.
  Qed.

  Local Lemma compare_helper_gt {a b : string} (G : cmp a b = Gt):
    lt b a.
  Proof.
    rewrite cmp_antisym in G.
    rewrite CompOpp_iff in G.
    now apply cmp_lt.
  Qed.

  Local Lemma compare_helper_eq {a b : string} (E : cmp a b = Eq):
    a = b.
  Proof.
    now apply cmp_eq.
  Qed.

  Definition compare (a b : string) : Compare lt eq a b :=
    match cmp a b as z return _ = z -> _ with
    | Lt => fun E => LT (compare_helper_lt E)
    | Gt => fun E => GT (compare_helper_gt E)
    | Eq => fun E => EQ (compare_helper_eq E)
    end Logic.eq_refl.

  Definition eq_dec (x y : string): {x = y} + { ~ (x = y)} := string_dec x y.
End String_as_OT.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e384m5x2e368m1_12limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma prime142948719999101 : prime 142948719999101.
Proof.
 apply (Pocklington_refl
         (Pock_certif 142948719999101 2 ((7256280203, 1)::(2,2)::nil) 1)
        ((Pock_certif 7256280203 2 ((33285689, 1)::(2,1)::nil) 1) ::
         (Pock_certif 33285689 3 ((4160711, 1)::(2,3)::nil) 1) ::
         (Pock_certif 4160711 7 ((416071, 1)::(2,1)::nil) 1) ::
         (Pock_certif 416071 13 ((3, 3)::(2,1)::nil) 28) ::
         (Proof_certif 3 prime3) ::
         (Proof_certif 2 prime2) ::
          nil)).
 vm_cast_no_check (refl_equal true).
Qed.

Lemma prime8901234567890123456789017: prime  8901234567890123456789017.
apply (Pocklington_refl

(SPock_certif
8901234567890123456789017
2
((11521380934487542399, 1)::nil))
(
(SPock_certif
11521380934487542399
2
((142948719999101, 1)::nil))
:: (Proof_certif 142948719999101 prime142948719999101) :: nil)).
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import List.
Import ListNotations.

Set Implicit Arguments.

Ltac break_match_hyp :=
  match goal with
    | [ H : context [ match ?X with _ => _ end ] |- _] =>
      match type of X with
        | sumbool _ _ => destruct X
        | _ => destruct X eqn:?
      end
  end.

Ltac break_match_goal :=
  match goal with
    | [ |- context [ match ?X with _ => _ end ] ] =>
      match type of X with
        | sumbool _ _ => destruct X
        | _ => destruct X eqn:?
      end
  end.

Ltac break_match := break_match_goal || break_match_hyp.

Section assoc.
  Variable K V : Type.
  Variable K_eq_dec : forall k k' : K, {k = k'} + {k <> k'}.

  Fixpoint assoc (l : list (K * V)) (k : K) : option V :=
    match l with
      | [] => None
      | (k', v) :: l' =>
        if K_eq_dec k k' then
          Some v
        else
          assoc l' k
    end.

  Definition assoc_default (l : list (K * V)) (k : K) (default : V) : V :=
    match (assoc l k) with
      | Some x => x
      | None => default
    end.

  Fixpoint assoc_set (l : list (K * V)) (k : K) (v : V) : list (K * V) :=
    match l with
      | [] => [(k, v)]
      | (k', v') :: l' =>
        if K_eq_dec k k' then
          (k, v) :: l'
        else
          (k', v') :: (assoc_set l' k v)
    end.

  Fixpoint assoc_del (l : list (K * V)) (k : K) : list (K * V) :=
    match l with
      | [] => []
      | (k', v') :: l' =>
        if K_eq_dec k k' then
          assoc_del l' k
        else
          (assoc_del l' k)
    end.

  Lemma get_set_diff :
    forall k k' v l,
      k <> k' ->
      assoc (assoc_set l k v) k' = assoc l k'.
  Proof using.
    induction l; intros; simpl; repeat (break_match; simpl); subst; try congruence; auto.
  Qed.

  Lemma get_del_same :
    forall k l,
      assoc (assoc_del l k) k = None.
  Proof using.
    induction l; intros; simpl in *.
    - auto.
    - repeat break_match; subst; simpl in *; auto.
      break_if; try congruence.
  Qed.

  Lemma get_set_diff_default :
    forall (k k' : K) (v : V) l d,
      k <> k' ->
      assoc_default (assoc_set l k v) k' d = assoc_default l k' d.
  Proof using.
    unfold assoc_default.
    intros.
    repeat break_match; auto;
    rewrite get_set_diff in * by auto; congruence.
  Qed.
End assoc.


(** Print Assumption and opaque modules :

  Print Assumption used to consider as axioms the modular fields
  unexported by their signature, cf bug report #2186. This should
  now be fixed, let's test this here. *)

(* First, a minimal test-case *)

Axiom foo : nat.

Module Type T.
 Parameter bar : nat.
End T.

Module M : T.
  Module Hide. (* An entire sub-module could be hidden *)
  Definition x := foo.
  End Hide.
  Definition bar := Hide.x.
End M.

Module N (X:T) : T.
  Definition y := X.bar. (* A non-exported field *)
  Definition bar := y.
End N.

Module P := N M.

Print Assumptions M.bar. (* Should answer: foo *)
Print Assumptions P.bar. (* Should answer: foo *)

(* The original test-case of the bug-report *)

Require Import Arith.

Axiom extensionality : forall P Q (f g:P -> Q),
  (forall x, f x = g x) -> f = g.

Module Type ADD_COMM_EXT.
  Axiom add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x).
End ADD_COMM_EXT.

Module AddCommExt_Opaque : ADD_COMM_EXT.
  Lemma add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x).
  Proof.
    intro n; apply extensionality; auto with arith.
  Qed.
End AddCommExt_Opaque.

Module AddCommExt_Transparent <: ADD_COMM_EXT.
  Lemma add_comm_ext : forall n, (fun x => x + n) = (fun x => n + x).
  Proof.
    intro n; apply extensionality; auto with arith.
  Qed.
End AddCommExt_Transparent.

Print Assumptions AddCommExt_Opaque.add_comm_ext.
(* Should answer: extensionality *)

Print Assumptions AddCommExt_Transparent.add_comm_ext.
(* Should answer: extensionality *)

Lemma add1_comm_ext_opaque :
  (fun x => x + 1) = (fun x => 1 + x).
Proof (AddCommExt_Opaque.add_comm_ext 1).

Lemma add1_comm_ext_transparent :
  (fun x => x + 1) = (fun x => 1 + x).
Proof (AddCommExt_Transparent.add_comm_ext 1).

Print Assumptions add1_comm_ext_opaque.
(* Should answer: extensionality *)

Print Assumptions add1_comm_ext_transparent.
(* Should answer: extensionality *)

Module Type FALSE_POSITIVE.
  Axiom add_comm : forall n x, x + n = n + x.
End FALSE_POSITIVE.

Module false_positive : FALSE_POSITIVE.
  Lemma add_comm : forall n x, x + n = n + x.
  Proof. auto with arith. Qed.

  Print Assumptions add_comm.
  (* Should answer : Closed under the global context *)
End false_positive.

Lemma comm_plus5 : forall x,
  x + 5 = 5 + x.
Proof (false_positive.add_comm 5).

Print Assumptions comm_plus5.
(* Should answer : Closed under the global context *)


(* begin hide *)
Require Export HoTT Ch05 HIT.TwoSphere.
(* end hide *)
(** printing <~> %\ensuremath{\eqvsym}% **)
(** printing == %\ensuremath{\sim}% **)
(** printing ^-1 %\ensuremath{^{-1}}% **)
(** * Higher Inductive Types *)

(** %\exerdone{6.1}{217}%
Define concatenation of dependent paths, prove that application of dependent
functions preserves concatenation, and write out the precise induction
principle for the torus $T^{2}$ with its computation rules.
*)

(** %\soln%
I found
%\href{http://ncatlab.org/homotopytypetheory/files/torus.pdf}{Kristina
Sojakova's answer posted to the HoTT Google group}%
helpful here, though I think my answer differs.

Let $W : \UU$, $P : W \to \UU$, $x, y, z : W$, $u : P(x)$, $v : P(y)$, and $w :
P(z)$ with $p : x = y$ and $q : y = z$.
We define the map
%\[
  \ctD : (\dpath{P}{p}{u}{v}) \to (\dpath{P}{q}{v}{w}) \to (\dpath{P}{p \ct q}{u}{w})
\]%
by path induction.
*)

Definition concatD {A} {P : A -> Type} {x y z : A}
           {u : P x} {v : P y} {w : P z}
           {p : x = y} {q : y = z} :
  (p # u = v) -> (q # v = w) -> ((p @ q) # u = w).
  by path_induction.
Defined.

Notation "p @D q" := (concatD p q)%path (at level 20) : path_scope.

(** %\noindent%
To prove that application of dependent functions preserves concatenation,
we must show that for any $f : \prd{x:A}P(x)$, $p : x = y$, and $q : y = z$,
%\[
  \mapdep{f}{p \ct q} = \mapdep{f}{p} \ctD \mapdep{f}{q}
\]%
which is immediate by path induction.
*)

Theorem apD_pp {A} {P : A -> Type} (f : forall x : A, P x)
        {x y z : A} (p : x = y) (q : y = z) :
  apD f (p @ q) = (apD f p) @D (apD f q).
Proof.
  by path_induction.
Defined.

(** %\noindent%
Suppose that we have a family $P : T^{2} \to \UU$, a point $b' : P(b)$, paths
$p' : \dpath{P}{p}{b'}{b'}$ and $q' : \dpath{P}{q}{b'}{b'}$ and a 2-path $t' :
\dpath{P}{t}{p' \ctD q'}{q' \ctD p'}$.  Then the induction principle gives a
section $f : \prd{x : T^{2}} P(x)$ such that $f(b) \equiv b'$, $f(p) = p'$, and
$f(q) = q'$.  As discussed in the text, we should also have $\apdtwo{f}{t} =
t'$, but this is not well-typed.  This is because $\apdtwo{f}{t} :
\dpath{P}{t}{f(p \ct q)}{f(q \ct p)}$, in contrast to the type of $t'$, and the
two types are not judgementally equal.

To cast $\apdtwo{f}{t}$ as the right type, note first that, as just proven,
$f(p \ct q) = f(p) \ctD f(q)$, and $f(q \ct p) = f(q) \ctD f(p)$.  The
computation rules for the 1-paths can be lifted as follows.
Let $r, r' : \dpath{P}{p}{u}{v}$, and $s, s' : \dpath{P}{q}{v}{w}$.  Then we
define a map
%\[
  \ctdD : (r = r') \to (s = s') \to (r \ctD s = r' \ctD s')
\]%
by path induction.
*)

Definition concat2D {A : Type} {P : A -> Type}
           {x y z : A} {p : x = y} {q : y = z}
           {u : P x} {v : P y} {w : P z}
           {r r' : p # u = v} {s s' : q # v = w} :
  (r = r') -> (s = s') -> (r @D s = r' @D s').
  by path_induction.
Defined.

Notation "p @@D q" := (concat2D p q)%path (at level 20) : path_scope.

(** %\noindent%
Thus by the computation rules for $p$ and $q$,
we have for $\alpha : f(p) = p'$ and $\beta : f(q) = q'$,
%\begin{align*}
  \alpha \ctdD \beta &: f(p) \ctD f(q) = p' \ctD q' \\
  \beta \ctdD \alpha &: f(q) \ctD f(p) = q' \ctD p'
\end{align*}%
At this point it's pretty clear how to assemble the computation rule.
Let $N_{1} : f(p \ct q) = f(p) \ctD f(q)$ and $N_{2} : f(q \ct p) = f(q) \ctD
f(p)$ be two instances of the naturality proof just given.  Then we have
%\[
  (\alpha \ctdD \beta)^{-1} \ct N^{-1}_{1}
  \ct \apdtwo{f}{t}
  \ct (\transtwo{t}{b'} \leftwhisker N_{2})
  \ct (\transtwo{t}{b'} \leftwhisker (\beta \ctdD \alpha))
  :
  \dpath{P}{t}{p' \ctD q'}{q' \ctD p'}
\]%
which is the type of $t'$.
*)

Module Torus_ex.

Private Inductive T2 : Type :=
| Tb : T2.

Axiom Tp : Tb = Tb.
Axiom Tq : Tb = Tb.
Axiom Tt : Tp @ Tq = Tq @ Tp.

Definition T2_rect (P : T2 -> Type)
           (b' : P Tb) (p' : Tp # b' = b') (q' : Tq # b' = b')
           (t' : p' @D q' = (transport2 P Tt b') @ (q' @D p'))
  : forall (x : T2), P x :=
  fun x => match x with Tb => fun _ _ _ => b' end p' q' t'.

Axiom T2_rect_beta_Tp :
  forall (P : T2 -> Type)
         (b' : P Tb) (p' : Tp # b' = b') (q' : Tq # b' = b')
         (t' : p' @D q' = (transport2 P Tt b') @ (q' @D p')),
    apD (T2_rect P b' p' q' t') Tp = p'.

Axiom T2_rect_beta_Tq :
  forall (P : T2 -> Type)
         (b' : P Tb) (p' : Tp # b' = b') (q' : Tq # b' = b')
         (t' : p' @D q' = (transport2 P Tt b') @ (q' @D p')),
    apD (T2_rect P b' p' q' t') Tq = q'.

Axiom T2_rect_beta_Tt :
  forall (P : T2 -> Type)
         (b' : P Tb) (p' : Tp # b' = b') (q' : Tq # b' = b')
         (t' : p' @D q' = (transport2 P Tt b') @ (q' @D p')),
    (T2_rect_beta_Tp P b' p' q' t' @@D T2_rect_beta_Tq P b' p' q' t')^
    @ (apD_pp (T2_rect P b' p' q' t') Tp Tq)^
    @ (apD02 (T2_rect P b' p' q' t') Tt)
    @ (whiskerL (transport2 P Tt (T2_rect P b' p' q' t' Tb))
                (apD_pp (T2_rect P b' p' q' t') Tq Tp))
    @ (whiskerL (transport2 P Tt (T2_rect P b' p' q' t' Tb))
                (T2_rect_beta_Tq P b' p' q' t' @@D T2_rect_beta_Tp P b' p' q' t'))
    = t'.

End Torus_ex.

(** %\exerdone{6.2}{217}%
Prove that $\susp\Sn^{1} \eqvsym \Sn^{2}$, using the explicit definition of
$\Sn^{2}$ in terms of $\base$ and $\surf$ given in %\S6.4%.
*)

(** %\soln%
$\Sn^{2}$ is generated by
 - $\base_{2} : \Sn^{2}$
 - $\surf : \refl{\base_{2}} = \refl{\base_{2}}$
and $\susp\Sn^{1}$ is generated by
 - $\north : \susp\Sn^{1}$
 - $\south : \susp\Sn^{1}$
 - $\merid : \Sn^{1} \to (\north = \south)$.
To define a map $f : \susp\Sn^{1} \to \Sn^{2}$, we need a map $m : \Sn^{1} \to
(\base_{2} = \base_{2})$, which we define by circle recursion such that
$m(\base_{1}) \equiv \refl{\base_{2}}$ and $m(\lloop) = \surf$.  Then recursion
on $\susp\Sn^{1}$ gives us our $f$, and we have $f(\north) \equiv \base_{2}$;
$f(\south) \equiv \base_{2}$; and for all $x : \Sn^{1}$, $f(\merid(x)) = m(x)$.

To go the other way, we use the recursion principle for the 2-sphere to obtain
a function $g : \Sn^{2} \to \susp\Sn^{1}$ such that $g(\base_{2}) \equiv
\north$ and $\aptwo{g}{\surf} = \merid(\lloop) \rightwhisker \merid(\base_{1})^{-1}$,
conjugated with proofs that $\merid(\base_{1}) \ct \merid(\base_{1})^{-1} =
\refl{\north}$.

Now, to show that this is an equivalence, we must show that the second map is a
quasi-inverse to the first.  First we show $g \circ f \sim
\idfunc{\susp\Sn^{1}}$.  For the poles we have
%\begin{align*}
  g(f(\north)) &\equiv g(\base_{2}) \equiv \north \\
  g(f(\south)) &\equiv g(\base_{2}) \equiv \north
\end{align*}%
and concatenating the latter with $\merid(\base_{1})$ gives $g(f(\south)) =
\south$.  Now we must show that for all $y : \Sn^{1}$, these equalities hold as
$x$ varies along $\merid(y)$.  That is, we must produce a path
%\[
  \transfib{x \mapsto g(f(x)) = x}{\merid(y)}{\refl{\north}} = \merid(\base_{1})
\]%
or, by Theorem 2.11.3 and a bit of path algebra,
%\[
  g(m(y))
  =
  \merid(y) \ct \merid(\base_{1})^{-1}
\]%
We do this by induction on $\Sn^{1}$.  When $y \equiv \base_{1}$, we have
%\[
  g(m(\base_{1}))
  =
  g(\refl{\base_{2}})
  =
  \refl{\base_{2}}
  =
  \merid(\base_{1}) \ct \merid(\base_{1})^{-1}
\]%
When $y$ varies along $\lloop$, we have to show that this proof continues to
hold.  By Theorem 2.11.3 and some path algebra, this in fact
reduces to
%\[
  \mapfunc{y \mapsto g(m(y))} \lloop
  =
  \merid(\lloop) \rightwhisker \merid(\base_{1})^{-1}
\]%
modulo the proofs of $\merid(\base_{1}) \ct \merid(\base_{1})^{-1} =
\refl{\north}$.  And this is essentially the computation rule for $g$.  Since
the computation rules are propositional some extra proofs have to be carried
around, though; see the second part of [isequiv_SS1_to_S2] for the gory details.

To show that $f \circ g \sim \idfunc{\Sn^{2}}$, note that
%\[
  f(g(\base_{2})) \equiv f(\north) \equiv \base_{2}
\]%
so we only need to show that as $x$ varies over the surface,
%\[
  \dpath{x \mapsto f(g(x)) =
  x}{\surf}{\refl{\refl{\base_{2}}}}{\refl{\refl{\base_{2}}}}
\]%
which means
%\[
 \refl{\refl{\base_{2}}} = \transtwo{\surf}{\refl{\base_{2}}}
  \equiv
  \mapfunc{p \mapsto p_{*} \refl{\base_{2}}}\surf
\]%
So we need to show that
%\[
  \refl{\refl{\base_{2}}} = \mapfunc{p \mapsto f(g(p^{-1})) \ct p} \surf
\]%
which by naturality of $\mapfunc{}$ and the computation rule for $\Sn^{1}$ is
%\[
  \refl{\refl{\base_{2}}}
  =
  \left(\aptwo{f}{\aptwo{g}{\surf}}\right)^{-1}
  \ct
  \surf
\]%
Naturality and the computation rules then give
%\[
  \aptwo{f}{\aptwo{g}{\surf}}
  = \aptwo{f}{\merid(\lloop)}
  = m(\lloop)
  = \surf
\]%
and we're done.*)

Definition equiv_functor_susp {A B : Type} (f : A -> B) `{IsEquiv A B f}
: Susp A <~> Susp B.
Proof.
  refine (equiv_adjointify (Susp_rec North South (merid o f))
                           (Susp_rec North South (merid o f^-1)) _ _);
  refine (Susp_ind _ 1 1 _);
  intro b; refine ((transport_paths_FFlr _ _) @ _);
  refine ((concat_pp_p _ _ _) @ _); apply moveR_Vp; symmetry;
  refine ((concat_p1 _) @ _);
  (* [Susp_rec_beta_merid] is called [Susp_comp_merid] in HoTT/master.  This
     uses the branch [jdoughertyii:spheres_with_S2], PR 782 *)
  refine ((ap (ap _) (Susp_rec_beta_merid b)) @ _);
  refine ((Susp_rec_beta_merid _) @ _);
  refine (_ @ (concat_1p _)^);
  f_ap; [apply eisretr | apply eissect].
Defined.

Definition ex6_2 : Susp S1 <~> S2.
Proof.
  equiv_via (Sphere 2).
  - apply equiv_inverse.
    refine (equiv_functor_susp Sph1_to_S1).
  - refine (BuildEquiv _ _ Sph2_to_S2 _).
Defined.

(** %\exer{6.3}{217}%
Prove that the torus $T^{2}$ as defined in %\S6.6%
is equivalent to $\Sn^{1} \times \Sn^{1}$.
*)

(** %\soln%
We first define $f : T^{2} \to \Sn^{1} \times \Sn^{1}$ by torus recursion,
using the maps
%\begin{align*}
  b &\mapsto (\base, \base) \\
  p &\mapsto \pair^{=}(\refl{\base}, \lloop)\\
  q &\mapsto \pair^{=}(\lloop, \refl{\base})\\
  \Phi(\alpha, \alpha) &: \lam{\alpha : x = x'}{\alpha' : y = y'}
    \left(\pair^{=}(\refl{x}, \alpha') \ct \pair^{=}(\alpha, \refl{y'})\right)
    =
    \left(\pair^{=}(\alpha, \refl{y}) \ct \pair^{=}(\refl{x'}, \alpha')\right) \\
  t &\mapsto \Phi(\lloop, \lloop)
\end{align*}%
Where $\Phi$ is defined by recursion on $\alpha$ and $\alpha'$.  To define a
function $f : \Sn^{1} \times \Sn^{1} \to T^{2}$, we need a function $\tilde{f}
: \Sn^{1} \to \Sn^{1} \to T^{2}$, which we'll define by double circle
recursion.  $\tilde{f}' : \Sn^{1} \to T^{2}$ is given by $b \mapsto \base$ and
$\lloop \mapsto p$.  Then $\tilde{f}$ is defined by $b \mapsto \tilde{f}'$ and
%\begin{align*}
  \lloop &\mapsto
\end{align*}%
*)

Definition Phi {A : Type} {x x' y y' : A} (alpha : x = x') (alpha' : y = y')
: ((path_prod (x, y) (x, y') 1 alpha') @ (path_prod (x, y') (x', y') alpha 1))
  = ((path_prod (x, y) (x', y) alpha 1) @ (path_prod (x', y) (x', y') 1 alpha')).
  induction alpha.
  induction alpha'.
  reflexivity.
Defined.

(** %\exer{6.4}{217}%
Define dependent $n$-loops and the action of dependent functions on $n$-loops,
and write down the induction principle for the $n$-spheres as defined at the
end of %\S6.4%.
*)

(** %\exer{6.5}{217}%
Prove that $\eqv{\susp\Sn^{n}}{\Sn^{n+1}}$, using the definition of $\Sn^{n}$
in terms of $\Omega^{n}$ from %\S6.4%.
*)

(** %\soln%
This definition defines $\Sn^{n}$ as the higher inductive type generated by
 - $\base_{n} : \Sn^{n}$
 - $\lloop_{n} : \Omega^{n}(\Sn^{n}, \base)$.
To define a function $\susp\Sn^{n} \to \Sn^{n+1}$, we send both $\north$ and
$\south$ to $\base_{n+1}$.  So we need a function $m : \Sn^{n} \to (\base_{n+1}
= \base_{n+1})$, for which we use $\Sn^{n}$-recursion.
*)

(** %\exer{6.6}{217}%
Prove that if the type $\Sn^{2}$ belongs to some universe $\UU$, then $\UU$ is
not a 2-type.
*)

(** %\exerdone{6.7}{217}%
Prove that if $G$ is a monoid and $x : G$, then $\sm{y:G}((x \cdot y = e)
\times (y \cdot x = e))$ is a mere proposition.  Conclude, using the principle
of unique choice, that it would be equivalent to define a group to be a monoid
such that for every $x : G$, there merely exists a $y : G$ such that $x \cdot y
= e$ and $y \cdot x = e$.
*)

(** %\soln%
Suppose that $G$ is a monoid and $x : G$.  Since $G$ is a set, each of $x
\cdot y = e$ and $y \cdot x = e$ are mere propositions.  The product preserves
this, so our type is of the form $\sm{y : G} P(y)$ for a family of mere
propositions $P : G \to \UU$.  Now, suppose that there is a point $u : \sm{y :
G} P(y)$; we show that this implies that this type is contractible, hence the
type is a mere proposition.  Since $P(y)$ is a mere proposition, we just need
to show that for any point $v : \sm{y : G} P(y)$, $\fst u = \fst v$.  But this
is just to say that if $\fst u$ has an inverse it is unique, and this is a
basic fact about inverses.

A group is defined to be a monoid together with an inversion function $i : G
\to G$ such that for all $x : G$, $x \cdot i(x) = e$ and $i(x) \cdot x = e$.
That is, the following type is inhabited:
%\[
  \sm{i : G \to G}\prd{x : G}\left(
    (x \cdot i(x) = e) \times (i(x) \cdot x = e)
  \right)
\]%
but this type is equivalent to the type
%\[
  \prd{x : G}\sm{y : G}
  \left(
    (x \cdot y = e) \times (y \cdot x = e)
  \right)
\]%
And as we have just shown, this is of the form $\prd{x:G} Q(x)$ for $Q$ a
family of mere propositions.  Thus, by the principle of unique choice, it
suffices to demand that for each $x : G$ we have $\brck{Q(x)}$.  Thus these two
requirements are equivalent.
*)

Class IsMonoid (A : hSet) (m : A -> A -> A) (e : A)
  := BuildIsMonoid {
         m_unitr : forall a : A, m a e = a ;
         m_unitl : forall a : A, m e a = a ;
         m_assoc : forall x y z : A, m x (m y z) = m (m x y) z
       }.

Record Monoid
  := BuildMonoid {
         m_set :> hSet ;
         m_mult :> m_set -> m_set -> m_set ;
         m_unit :> m_set ;
         m_ismonoid :> IsMonoid m_set m_mult m_unit
       }.

Theorem hprop_inverse_exists (G : hSet) (m : G -> G -> G) (e : G)
        (HG : IsMonoid G m e)
: forall x, IsHProp {y : G & (m x y = e) * (m y x = e)}.
Proof.
  intro x.
  (* reduce to uniqueness of inverse *)
  assert (forall y : G, IsHProp ((m x y = e) * (m y x = e))). intro y.
  apply hprop_prod; intros p q; apply G.
  apply hprop_inhabited_contr. intro u. exists u.
  intro v. apply path_sigma_hprop.

  (* inverse is unique *)
  destruct HG.
  refine ((m_unitr0 _)^ @ _).
  refine (_ @ (m_unitl0 _)).
  path_via (m u.1 (m x v.1)). f_ap. symmetry. apply (fst v.2).
  path_via (m (m u.1 x) v.1). f_ap. apply (snd u.2).
Defined.

Class IsGroup (A : Monoid) (i : A -> A)
  := BuildIsGroup {
         g_invr : forall a : A, (m_mult A) a (i a) = (m_unit A) ;
         g_invl : forall a : A, (m_mult A) (i a) a = (m_unit A)
       }.

Record Group
  := BuildGroup {
         g_monoid :> Monoid ;
         g_inv :> (m_set g_monoid) -> (m_set g_monoid) ;
         g_isgroup :> IsGroup g_monoid g_inv
       }.

Theorem issig_group `{Funext} :
  {G : Monoid & {i : G -> G & forall a, (G a (i a) = G) * (G (i a) a = G)}}
    <~>
    Group.
Proof.
  apply (@equiv_compose' _ {G : Monoid & {i : G -> G & IsGroup G i}} _).
  issig BuildGroup g_monoid g_inv g_isgroup.
  apply equiv_functor_sigma_id. intro G.
  apply equiv_functor_sigma_id. intro i.
  apply (@equiv_compose' _
                         {_ : forall a, (G a (i a) = G)
                                & (forall a : G, G (i a) a = G)}
                         _).
  issig (BuildIsGroup G i) (@g_invr G i) (@g_invl G i).
  simple refine (equiv_adjointify _ _ _ _); intro z.
    apply (fun a => fst (z a); fun a => snd (z a)).
    apply (fun a => (z.1 a, z.2 a)).
    destruct z as [g h]. apply path_sigma_uncurried. exists 1. reflexivity.
    apply path_forall; intro a. apply eta_prod.
Defined.

Theorem ex6_7 `{Funext} :
  {G : Monoid & forall x, Brck {y : G & (G x y = G) * (G y x = G)}}
  <~>
  Group.
Proof.
  apply (@equiv_compose' _
                         {G : Monoid &
                          forall x : G, {y : G & (G x y = G) * (G y x = G)}}
                         _).
  apply (@equiv_compose' _
                         {G : Monoid &
                         {i : G -> G &
                          forall a, (G a (i a) = G) * (G (i a) a = G)}}
                         _).
  apply issig_group.
  apply equiv_functor_sigma_id. intro G.
  apply equiv_inverse. refine (equiv_sigT_coind _ _).
  apply equiv_functor_sigma_id. intro G.
  apply equiv_functor_forall_id. intro x.
  apply equiv_inverse.
  apply ex3_21.
  destruct G as [G m e HG]. simpl in *.
  apply hprop_inverse_exists.
  apply HG.
Defined.

(** %\exer{6.8}{217}%
Prove that if $A$ is a set, then $\lst{A}$ is a monoid.  Then complete the
proof of Lemma 6.11.5.
*)

(** %\soln%
We first characterise the path space of $\lst{A}$, which goes just as $\N$.
We define the codes
%\begin{align*}
    \codefunc(\nil, \nil) &\defeq \unit \\
    \codefunc(\cons(h, t), \nil) &\defeq \emptyt \\
    \codefunc(\nil, \cons(h', t')) &\defeq \emptyt \\
    \codefunc(\cons(h, t), \cons(h', t')) &\defeq (h=h') \times \codefunc(t, t')
\end{align*}%
and the function $r : \prd{\ell : \lst{A}} \codefunc(\ell, \ell)$ by
%\begin{align*}
        r(\nil) &\defeq \star \\
        r(\cons(h, t)) &\defeq (\refl{h}, r(t))
\end{align*}%
Now, for all $\ell, \ell' : \lst{A}$, $\eqv{(\ell = \ell')}{\codefunc(\ell,
\ell')}$.  To prove this, we define
%\[
  \encode(\ell, \ell', p) \defeq \transfib{\codefunc(\ell, -)}{p}{r(\ell)}
\]%
and we define $\decode$ by double induction on $\ell, \ell'$.  When they're
both $\nil$, send everything to $\refl{\nil}$.  When one is $\nil$ and the
other a $\cons$, we use the eliminator for $\emptyt$.  When they're both a
cons, we define
%\begin{align*}
  \codefunc(\cons(h, t), \cons(h', t'))
  &\equiv
  (h = h') \times \codefunc(t, t') \\
  &\xrightarrow{\idfunc{h=h'} \times \decode(t, t')}
  (h = h') \times (t = t') \\
  &\xrightarrow{\pair^{=}}
  ((h, t) = (h', t')) \\
  &\xrightarrow{\mapfunc{\lam{z}\cons(\fst z, \snd z)}}
  (\cons(h, t) = \cons(h', t'))
\end{align*}%
It follows easily from induction on everything and naturality that these are
quasi-inverses.  The only point of note is that the fact that $A$ is a set is
required in the proof of
%\[
  \encode(\ell, \ell', \decode(\ell, \ell', z)) = z
\]%
This is because our definition of $\encode$ involved an arbitrary choice in
how $r$ acts on $\cons$, and this choice is only preserved up to homotopy.
*)

Local Open Scope list_scope.

Fixpoint list_code {A : Type} (l l' : list A) : Type :=
  match l with
    | nil => match l' with
               | nil => Unit
               | h' :: t' => Empty
             end
    | h :: t => match l' with
                    | nil => Empty
                    | h' :: t' => (h = h') * (list_code t t')
                  end
  end.

Fixpoint list_r {A : Type} (l : list A) : list_code l l :=
  match l with
    | nil => tt
    | h :: t => (1, list_r t)
  end.

Definition list_encode {A : Type} (l l' : list A) (p : l = l') :=
  transport (fun x => list_code l x) p (list_r l).

Definition list_decode {A : Type} :
  forall (l l' : list A) (z : list_code l l'), l = l'.
  induction l as [| h t]; destruct l' as [| h' t']; intros.
    reflexivity. contradiction. contradiction.
    apply (@ap _ _ (fun x => cons (fst x) (snd x)) (h, t) (h', t')).
    apply path_prod. apply (fst z). apply IHt. apply (snd z).
Defined.

Definition path_list {A : Type} : forall (h h' : A) (t t' : list A),
  h = h' -> t = t' -> h :: t = h' :: t'.
Proof.
  intros h h' t t' ph pt.
  apply (list_decode _ _). split.
    apply ph.
    apply (list_encode _ _). apply pt.
Defined.

Theorem equiv_path_list {A : Type} {H : IsHSet A} (l l' : list A) :
  (list_code l l') <~> (l = l').
Proof.
  refine (equiv_adjointify (list_decode l l') (list_encode l l') _ _).

  (* lst_decode o lst_encode == id *)
  intro p. induction p.
  induction l as [|h t]. reflexivity. simpl in *.
  refine (_ @ (ap_1 _ _)). f_ap.
  transitivity (path_prod (h, t) (h, t) 1 1). f_ap. reflexivity.

  (* lst_encode o lst_decode == id *)
  generalize dependent l'.
  induction l as [|h t], l' as [|h' t']; intro z.
    apply contr_unit. contradiction. contradiction.
    simpl. unfold list_encode.
    refine ((transport_compose _ _ _ _)^ @ _).
    refine ((transport_prod
               (path_prod (h, t) (h', t') (fst z) (list_decode t t' (snd z)))
               (1, list_r t)) @ _).
    destruct z as [p c].
    apply path_prod. apply H.
    refine ((transport_path_prod _ _ _ _) @ _).
    induction p. apply (IHt t').
Defined.

(** %\noindent%
It's now easy to see that $\lst{A}$ is a set, by induction.
If $\ell \equiv \ell' \equiv \nil$, then $\eqv{(\ell = \ell')}{\unit}$, which
is contractible.
Similarly, if only one is $\nil$ then $\eqv{(\ell = \ell')}{\emptyt}$, which
is contractible.
Finally, if both are $\cons$es, then the path space is $(h = h') \times
\codefunc(t, t')$.  The former is contractible because $A$ is a set, and the
latter is contractible by the induction hypothesis.  Contractibility is
preserved by products, so the path space is contractible.
*)

(*
Theorem set_list_is_set (A : Type) : IsHSet A -> IsHSet (list A).
Proof.
  intros HA l.
  induction l as [|h t].
    intro l'; destruct l' as [|h' t'].
    apply (trunc_equiv (equiv_path_list nil nil)).
    apply (trunc_equiv (equiv_path_list nil (h' :: t'))).
    intro l'; destruct l' as [|h' t'].
    apply (trunc_equiv (equiv_path_list (h :: t) nil)).
    transparent assert (r : (IsHProp (list_code (h :: t) (h' :: t')))).
    simpl. apply hprop_prod.
    apply hprop_allpath. apply HA.
    apply (trunc_equiv (equiv_path_list t t')^-1).
    apply (trunc_equiv (equiv_path_list (h :: t) (h' :: t'))).
Defined.
*)

(** Now, to show that $\lst{A}$ is a monoid, we must equip it with a
multiplication function and a unit element.  For the multiplication function we
use append, and for the unit we use $\nil$.  These must satisfy two properties.
First we must have, for all $\ell : \lst{A}$, $\ell \cdot \nil = \nil \cdot
\ell = \ell$, which we clearly do.  Second, append must be associative, which
it clearly is.
*)

(* move these elsewhere *)

Theorem app_nil_r {A : Type} : forall l : list A, l ++ nil = l.
Proof. induction l. reflexivity. simpl. f_ap. Defined.

Theorem app_assoc {A : Type} : forall x y z : list A,
  x ++ (y ++ z) = (x ++ y) ++ z.
Proof.
  intros x y z. induction x. reflexivity.
  simpl. apply path_list. reflexivity. apply IHx.
Defined.

(*
Theorem set_list_is_monoid {A : Type} {HA : IsHSet A} :
  IsMonoid (@BuildhSet (list A) (set_list_is_set _ HA)) (@app A) nil.
Proof.
  apply BuildIsMonoid.
  apply app_nil_r. reflexivity.
  apply app_assoc.
Defined.
*)

(** Now, Lemma 6.11.5 states that for any set $A$, the type $\lst{A}$ is the
free monoid on $A$.  That is, there is an equivalence
%\[
  \eqv{
    \hom_{\text{Monoid}}(\lst{A}, G)
  }{
    (A \to G)
  }
\]%
There is an obvious inclusion $\eta : A \to \lst{A}$ defined by $a \mapsto
\cons(a, \nil)$, and this defines a map $({-} \circ \eta)$ giving the forward
direction of the equivalence.  For the other direction, suppose that $f : A \to
G$.  We lift this to a map $\bar{f} : \lst{A} \to G$ by recursion:
%\begin{align*}
  \bar{f}(\nil) &\defeq e \\
  \bar{f}(\cons(h, t)) &\defeq f(h) \cdot \bar{f}(t)
\end{align*}%
To show that this is a monoid homomorphism, we must show
%\begin{align*}
  \bar{f}(\nil) &= e \\
  \bar{f}(\ell \cdot \ell') &= \bar{f}(\ell) \cdot \bar{f}(\ell')
\end{align*}%
The first is a judgemental equality, so we just need to show the second, which
we do by induction on $\ell$.  When $\ell \equiv \nil$ we have
%\[
  \bar{f}(\nil \cdot \ell')
  \equiv
  \bar{f}(\ell')
  =
  e \cdot \bar{f}(\ell')
  \equiv
  \bar{f}(\nil) \cdot \bar{f}(\ell')
\]%
and when it is a cons,
%\begin{align*}
  \bar{f}(\cons(h, t) \cdot \ell')
  &=
  \bar{f}(\cons(h, t \cdot \ell'))
  =
  f(h) \cdot \bar{f}(t \cdot \ell')
  =
  f(h) \cdot \bar{f}(t) \cdot \bar{f}(\ell')
  =
  f(\cons(h, t)) \cdot \bar{f}(\ell')
\end{align*}%
by the induction hypothesis in the third equality.  So $\bar{f}$ is a monoid
homomorphism.

To show that these are quasi-inverses, suppose that $f :
\hom_{\text{Monoid}}(\lst{A}, G)$.  Then we must show that
%\[
  \overline{f \circ \eta} = f
\]%
which we do by function extensionality and induction.  When $\ell \equiv \nil$,
we have
%\[
  \overline{f \circ \eta}(\nil) \equiv e = f(\nil)
\]%
Since $f$ is a monoid homomorphism.  When $\ell \equiv \cons(h, t)$,
%\begin{align*}
  \overline{f \circ \eta}(\cons(h, t))
  &\equiv
  f(\eta(h))
  \cdot
  \overline{f \circ \eta}(t)
  =
  f(\eta(h))
  \cdot
  f(t)
  =
  f(\cons(h, \nil) \cdot t)
  \equiv
  f(\cons(h, t))
\end{align*}%
So by function extensionality $\overline{f \circ \eta} = f$.  We must
also show that the proofs that $\overline{f \circ \eta}$ and $f$ are
monoid homomorphisms are equal.  This turns out to be trivial,
however: since monoids are structures on sets, all of the relevant
proofs are of equalities in sets, so the structures are mere
propositions, and equality of the underlying maps is equivalent to
equality of the homomorphisms.

For the other direction, suppose that $f : A \to G$.  We show that
%\[
  \bar{f} \circ \eta = f
\]%
again by function extensionality.  Suppose that $a : A$; then
%\[
  \bar{f}(\eta(a))
  \equiv \bar{f}(\cons(a, \nil))
  \equiv f(a) \cdot \bar{f}(\nil)
  \equiv f(a) \cdot e
  = f(a)
\]%
and we're done.
*)

Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Class IsMonoidHom {A B : Monoid} (f : A -> B) :=
  BuildIsMonoidHom {
      hunit : f (m_unit A) = m_unit B ;
      hmult : forall a a' : A, f ((m_mult A) a a') = (m_mult B) (f a) (f a')
    }.

Record MonoidHom (A B : Monoid) :=
  BuildMonoidHom {
      mhom_fun :> A -> B ;
      mhom_ismhom :> IsMonoidHom mhom_fun
    }.

(*
Definition homLAG_to_AG (A : Type) (HA : IsHSet A) (G : Monoid) :
  MonoidHom (BuildMonoid (@BuildhSet (list A) (set_list_is_set _ HA))
                         _ _ set_list_is_monoid)
            G
  -> (A -> G)
  := fun f a => (mhom_fun _ G f) [a].
*)

(*
Definition AG_to_homLAG (A : Type) (HA : IsHSet A) (G : Monoid) :
  (A -> G)
  ->
  MonoidHom (BuildMonoid (@BuildhSet (list A) (set_list_is_set _ HA))
                         _ _ set_list_is_monoid)
            G.
Proof.
  (* lift f by recursion *)
  intro f.
  refine (BuildMonoidHom _ G _ _).
  intro l. induction l as [|h t].
  apply (m_unit G).
  apply ((m_mult _) (f h) IHt).

  apply BuildIsMonoidHom.
  (* takes the unit to the unit *)
  reflexivity.

  (* respects multiplication *)
  simpl. intro l. induction l. intro l'. simpl.
  refine (_ @ (m_unitl _)^). reflexivity. apply G.

  intro l'. simpl. refine (_ @ (m_assoc _ _ _)).
  f_ap. apply (m_unit _). apply G.
Defined.
*)

Theorem isprod_ismonoidhom {A B : Monoid} (f : A -> B) :
  (f (m_unit A) = m_unit B)
  * (forall a a', f ((m_mult A) a a') = (m_mult B) (f a) (f a'))
  <~>
  IsMonoidHom f.
Proof.
  (* I think this should be a judgemental equality, but it's not *)
  etransitivity {_ : f A = B & forall a a' : A, f (A a a') = B (f a) (f a')}.
  simple refine (equiv_adjointify _ _ _ _); intro z.
    exists (fst z). apply (snd z). apply (z.1, z.2).
    apply eta_sigma. apply eta_prod.

  issig (BuildIsMonoidHom A B f) (@hunit A B f) (@hmult A B f).
Defined.

(*
Theorem hprop_ismonoidhom `{Funext} {A B : Monoid} (f : A -> B)
  : IsHProp (IsMonoidHom f).
Proof.
  refine (trunc_equiv' (isprod_ismonoidhom f)).
Defined.
*)

Theorem issig_monoidhom (A B : Monoid) :
  {f : A -> B & IsMonoidHom f} <~> MonoidHom A B.
Proof.
  issig (BuildMonoidHom A B) (@mhom_fun A B) (@mhom_ismhom A B).
Defined.

(*
Theorem equiv_path_monoidhom `{Funext} {A B : Monoid} {f g : MonoidHom A B} :
  ((mhom_fun _ _ f) = (mhom_fun _ _ g)) <~> f = g.
Proof.
  equiv_via ((issig_monoidhom A B)^-1 f = (issig_monoidhom A B)^-1 g).
  refine (@equiv_path_sigma_hprop
            (A -> B) IsMonoidHom hprop_ismonoidhom
            ((issig_monoidhom A B)^-1 f) ((issig_monoidhom A B)^-1 g)).
  apply equiv_inverse. apply equiv_ap. refine _.
Defined.
*)

(*
Theorem list_is_free_monoid `{Funext} (A : Type) (HA : IsHSet A) (G : Monoid) :
  MonoidHom (BuildMonoid ((@BuildhSet (list A) (set_list_is_set _ HA)))
                         _ _ set_list_is_monoid)
            G
            <~>
            (A -> G).
Proof.
  transparent assert (HG : (IsMonoid G G G)). apply G.
  refine (equiv_adjointify (homLAG_to_AG _ _ _) (AG_to_homLAG _ _ _) _ _).
  intro f. apply path_forall; intro a.
  simpl. apply (m_unitr _).

  intro f. apply equiv_path_monoidhom. apply path_forall; intro l.
  induction l as [|h t]; simpl.
  symmetry. apply (@hunit _ _ f). apply f.
  transitivity (G (homLAG_to_AG A HA G f h) (f t)). f_ap.
  unfold homLAG_to_AG. refine (@hmult _ _ f _ [h] t)^. apply f.
Defined.
*)

Local Close Scope list_scope.

(** %\exer{6.9}{217}%
Assuming $\LEM{}$, construct a family $f : \prd{X : \UU} (X \to X)$ such that
$f_{\bool} : \bool \to \bool$ is the nonidentity automorphism.
*)

(** %\exer{6.10}{218}%
Show that the map constructed in Lemma 6.3.2 is in fact a quasi-inverse to
$\happly$, so that the interval type implies the full function extensionality
axiom.
*)

(** %\soln%
Of course, it's easiest to prove the full function extensionality axiom by
referring to Exercise 2.16.  But we want to show something more: that this map
is an inverse to $\happly$.
Let $f, g : A \to B$, and suppose that $p : f = g$.  Then $\happly(p) :
\prd{x:A}f(x) = g(x)$.  For all $x : A$ we define a function $\tilde{h} : I \to
B$ by
%\begin{align*}
 \tilde{h}_{x}(0_{I}) &\defeq f(x),  \\
 \tilde{h}_{x}(1_{I}) &\defeq g(x),  \\
 \mapfunc{\tilde{h}_{x}}(\seg) &\defeq \happly(p, x)
\end{align*}%
and we define $q : I \to (A \to B)$ by $q(i) \defeq \lam{x}\tilde{h}_{x}(i)$.
Thus
%\[
  \mapfunc{q}(\seg) \equiv \mapfunc{\lam{x}\tilde{h}_{x}}(\seg)
\]%
*)

Module Exercise6_10.

Module Interval.

Private Inductive interval : Type :=
  | zero : interval
  | one : interval.

Axiom seg : zero = one.

Definition interval_rect (P : interval -> Type)
  (a : P zero) (b : P one) (p : seg # a = b)
  : forall x : interval, P x
  := fun x => (match x return _ -> P x with
                 | zero => fun _ => a
                 | one => fun _ => b
               end) p.

Axiom interval_rect_beta_seg : forall (P : interval -> Type)
  (a : P zero) (b : P one) (p : seg # a = b),
  apD (interval_rect P a b p) seg = p.

End Interval.

(*
Definition interval_rectnd (P : Type) (a b : P) (p : a = b)
  : interval -> P
  := interval_rect (fun _ => P) a b (transport_const _ _ @ p).
*)

(*
Definition interval_rectnd_beta_seg (P : Type) (a b : P) (p : a = b)
  : ap (interval_rectnd P a b p) seg = p.
Proof.
  refine (cancelL (transport_const seg a) _ _ _).
  refine ((apD_const (interval_rect (fun _ => P) a b _) seg)^ @ _).
  refine (interval_rect_beta_seg (fun _ => P) _ _ _).
Defined.
*)

(*
Definition interval_path_arrow {A B : Type} {f g : A -> B}
  : (f == g) -> (f = g)
  := fun p => ap (fun i a => interval_rectnd B (f a) (g a) (p a) i) seg.
*)

(*
Theorem ex6_10_alpha {A B : Type} {f g : A -> B}
  : (@ap10 A B f g) o (@interval_path_arrow A B f g) == idmap.
Proof.
Admitted.
*)

(*
Theorem ex6_10_beta {A B : Type} {f g : A -> B}
  : (@interval_path_arrow A B f g) o (@ap10 A B f g) == idmap.
Proof.
  intro p. unfold compose.
  set (q := (fun i a => interval_rectnd B (f a) (g a) (ap10 p a) i)).
Admitted.
*)

End Exercise6_10.

(** %\exerdone{6.11}{218}%
Prove the universal property of suspension:
%\[
  \eqv{ \left(\susp A \to B \right) }{ \left(\sm{b_{n} : B}\sm{b_{s} : B} (A \to (b_{n} = b_{s}))\right) }
\]%
*)

(** %\soln%
To construct an equivalence, suppose that $f : \susp A \to B$.  Then there are
two elements $f(\north), f(\south) : B$ such that there is a map $A \to
(f(\north) = f(\south))$; in particular for any element $a : A$ we have the
element $\merid(a) : (\north = \south)$ which may be pushed forward to give
$f(\merid(a)) : f(\north) = f(\south)$.  For the other direction, suppose that
we have elements $b_{n}, b_{s} : B$ such that $f : A \to (b_{n} = b_{s})$.
Then by suspension recursion we define a function $g : \susp A \to B$ such that
$g(\north) \equiv b_{n}$, $g(\south) \equiv b_{s}$, and $g(\merid(a)) = f(a)$
for all $a : \susp A$.

To show that these are quasi-inverses, suppose that $f : \susp A \to B$.  We
then construct the element $(f(\north), f(\south), \lam{a}f(\merid(a)))$ of the
codomain, and going back gives a function $g : \susp A \to B$ such that
$g(\north) \equiv f(\north)$, $g(\south) \equiv f(\south)$, and $g(\merid(a)) =
f(\merid(a))$ for all $a : \susp A$.  But this just means that $g$ and $f$ have
the same recurrence relation, so we're back where we started.

For the other loop, suppose that we have an element $(b_{n}, b_{s}, f)$ of the
right.  Then we get an arrow $g : \susp A \to B$ on the left such that
$g(\north) = b_{n}$, $g(\south) = b_{s}$, and $g(\merid(a)) = f(a)$ for all $a
: \susp A$.  Going back to the right, we have the element $(b_{n}, b_{s}, f)$,
homotopic to the identity function.
*)

Theorem univ_prop_susp `{Funext} {A B : Type} :
  (Susp A -> B) <~> {bn : B & {bs : B & A -> (bn = bs)}}.
Proof.
  simple refine (equiv_adjointify _ _ _ _).
  intro f. exists (f North). exists (f South). intro a. apply (ap f (merid a)).
  intro w. destruct w as [bn [bs f]]. apply (Susp_rec bn bs f).

  intro w. destruct w as [bn [bs f]].
  apply path_sigma_uncurried. exists 1.
  apply path_sigma_uncurried. exists 1.
  apply path_forall; intro a. simpl.
  apply Susp_rec_beta_merid.

  intro f. apply path_forall.
  refine (Susp_ind _ 1 1 _).
  intro a.
  simpl.
  refine ((@transport_paths_FlFr _ _ _ f _ _ _ _) @ _).
  apply moveR_pM.
  refine ((concat_p1 _) @ _). refine (_ @ (concat_1p _)^). apply inverse2.
  refine ((Susp_rec_beta_merid _) @ _).
  reflexivity.
Defined.

(** %\exer{6.12}{218}%
Show that $\eqv{\Z}{\N + \unit + \N}$.  Show that if we were to define $\Z$ as
$\N + \unit + \N$, then we could obtain Lemma 6.10.12 with judgmental
computation rules.
*)

(** %\soln%
Let $\Z \defeq \sm{x : \N \times \N} (r(x) = x)$, where
%\[
  r(a, b) = \begin{cases}
    (a - b, 0) & \text{if $a \geq b$} \\
    (0, b - a) & \text{otherwise}
 \end{cases}
\]%
To define the forward direction, let $((a, b), p) : \Z$.  If $a = b$, then
produce $\star$.  Otherwise, if $a > b$, produce $\pred(a - b)$ in the right
copy of $\N$.  Otherwise (i.e., when $a < b$), produce $\pred(b - a)$ in the
left copy of $\N$.  To go the other way, we have three cases.  When $n$ is
in the left, send it to $(0, \suc(n))$, along with the appropriate proof.  When
$n \equiv \star$, produce $(0, 0)$.  When $n$ is in the right, send it to
$(\suc(n), 0)$.  Clearly, these two constructions are quasi-inverses, since
$\suc(\pred(n)) = n$ for all $n \neq 0$.

Now define $\Z \defeq \N + \unit + \N$.  I just can't seem to get the right
computation rules!  I can get
%\[
  f(\suc(\suc(n)))
  \equiv
  d_{+}(\suc(n), f(\suc(n)))
\]%
and so on, but this isn't what we want.  The problem has to do with the
apparent necessity of $\pred$ in the encoding of the integers.  I suppose I
could try a different encoding.

*)

Lemma hset_prod : forall A, IsHSet A -> forall B, IsHSet B -> IsHSet (A * B).
Proof.
  intros A HA B HB.
  intros z z'. apply hprop_allpath. apply path_ishprop.
Defined.

Module Exercise6_12.

Fixpoint monus n m :=
  match m with
    | O => n
    | S m' => pred (monus n m')
  end.

Lemma monus_O_n : forall n, monus O n = O.
Proof. induction n. reflexivity. simpl. change O with (pred O). f_ap. Defined.

Lemma n_le_Sn : forall n, le n (S n).
Proof. intro n. exists (S O). apply (plus_1_r n)^. Defined.

Lemma monus_eq_O__n_le_m : forall n m, (monus n m = O) -> (le n m).
Admitted.

Lemma monus_self : forall n, monus n n = O.
Admitted.

Definition n_le_m__Sn_le_Sm : forall (n m : nat), (le n m) -> (le (S n) (S m))
  := fun n m H => (H.1; ap S H.2).

Lemma order_partitions : forall (n m : nat), (le n m) + (lt m n).
Proof.
  induction n.
    intro m. left. exists m. reflexivity.
  induction m.
    right. exists n. reflexivity.
    destruct IHm.
      left. destruct l as [x p]. exists (S x).
      simpl. apply (ap S). apply ((plus_n_Sm _ _)^ @ p).
      destruct (IHn m).
        left. apply n_le_m__Sn_le_Sm. apply l0.
        right. destruct l0 as [x p]. exists x. simpl. apply (ap S). apply p.
Defined.

Definition r : nat * nat -> nat * nat.
  intro z. destruct z as [a b].
  destruct (order_partitions b a).
  apply (monus a b, O).
  apply (O, monus b a).
Defined.

Definition int := {x : nat * nat & r x = x}.

Definition int_to_nat_1_nat : int -> (nat + Unit + nat).
  intro z. destruct z as [[a b] p]. destruct (decidable_paths_nat a b).
  left. right. apply tt.
  destruct (order_partitions b a).
  right. apply (pred (monus a b)).
  left. left. apply (pred (monus b a)).
Defined.

Definition nat_1_nat_to_int : (nat + Unit + nat) -> int :=
  fun z =>
    match z with
      | inl a => match a with
                   | inl n => ((O, S n); 1)
                   | inr _ => ((O, O); 1)
                 end
      | inr n => ((S n, O); 1)
    end.

Lemma lt_le : forall n m, (lt n m) -> (le n m).
Proof.
  intros n m p. destruct p as [k p]. exists (S k).
  apply p.
Defined.

Theorem ex6_12 : int <~> (nat + Unit + nat).
Proof.
  refine (equiv_adjointify int_to_nat_1_nat nat_1_nat_to_int _ _).

  intro z. destruct z as [[n | n] | n].
  reflexivity.
  unfold int_to_nat_1_nat. simpl. repeat f_ap. apply contr_unit. reflexivity.

  intro z. destruct z as [[a b] p].
  apply path_sigma_uncurried.
  assert (
    (nat_1_nat_to_int (int_to_nat_1_nat ((a, b); p))).1 = ((a, b); p).1
  ) as H.
  unfold nat_1_nat_to_int, int_to_nat_1_nat, r in *. simpl in *.
  destruct (decidable_paths_nat a b).
  destruct (order_partitions b a). refine (_ @ p).
    apply path_prod.
    assert (b = O). apply (ap snd p)^.
    assert (a = O). apply (p0 @ X).
    simpl. transitivity (monus a 0). simpl. apply X0^. f_ap. apply X^.
    reflexivity.
    assert (a = O). apply (ap fst p)^. assert (b = O). apply (p0^ @ X). simpl.
    apply path_prod. apply X^. apply X0^.

  destruct (order_partitions b a); refine (_ @ p);
    apply path_prod.
    simpl. refine ((Spred _ _) @ _).
    intro H. apply monus_eq_O__n_le_m in H.
    apply le_antisymmetric in H. symmetry in H. apply n in H. contradiction.
    apply l. reflexivity. reflexivity. reflexivity.
    simpl. refine ((Spred _ _) @ _).
    intro H.
    assert (a = b). refine ((ap fst p)^ @ H^ @ (ap snd p)).  apply n in X.
    contradiction. reflexivity. simpl in *.

    exists H.
    assert (IsHSet (nat * nat)) as Hn. apply hset_prod; apply hset_nat.
    apply set_path2.
Defined.

Definition int' := nat + Unit + nat.

End Exercise6_12.


Require Export String.
From Undecidability.L Require Export Preliminaries.

(** * Definition of L *)
(** ** Syntax *)

Inductive term : Type :=
| var (n : nat) : term
| app (s : term) (t : term) : term
| lambda (s : term).

Definition lam s := exists t, s = lambda t.
Hint Unfold lam.

Lemma lambda_lam s : lam (lambda s).
Proof.
  now exists s.
Qed.
Hint Resolve lambda_lam.

Fixpoint size t :=
  match t with
  | var n => 1
  | app s t => size s + size t
  | lambda s => 1 + size s
  end.

Coercion app : term >-> Funclass.
Coercion var : nat >-> term.

Instance term_eq_dec : eq_dec term.
Proof.
  intros ? ?; hnf; repeat decide equality.
Defined.

Hint Resolve term_eq_dec.

(** ** Named abstractions *)

Require Import String.

Inductive bterm : Type :=
| bvar (x : string) : bterm
| bapp (s t : bterm) : bterm
| blambda (x : string) (s : bterm) : bterm
| bter (s : term) : bterm.

Open Scope string_scope.

Instance eq_dec_string : eq_dec string.
Proof.
  eapply string_dec.
Defined.

Fixpoint convert' (F : list string) (s : bterm) : term := match s with
| bvar x => match pos _ x F with None => 100 | Some t =>  t end
| bapp s t => app (convert' F s) (convert' F t)
| blambda x s => lambda (convert' (x:: F) s)
| bter t => t
end.

Coercion bvar : string >-> bterm.
Coercion bapp : bterm >-> Funclass.
Definition convert := convert' [].
Coercion convert : bterm >-> term.

Arguments convert /.

Hint Unfold convert: cbv.

Notation ".\ x , .. , y ; t" := ((blambda x .. (blambda y t) .. )) (at level 100, right associativity).
Notation "'λ'  x , .. , y ; t" := ((blambda x .. (blambda y t) .. )) (at level 100, right associativity).

Notation "'!' s" := (bter s) (at level 0).

Implicit Types s t u v : term.
Implicit Types p q : term -> Prop.
Implicit Types n m k l : nat.

(** ** Substitution and closedness *)

Fixpoint subst s k u :=
  match s with
      | var n => if decision (n = k) then u else (var n)
      | app s t => app (subst s k u) (subst t k u)
      | lambda s => lambda (subst s (S k) u)
  end.
Hint Unfold subst : cbv.

Fixpoint bound (k : nat) (t : term) : bool :=
match t with
| var n => if decision (n < k) then true else false
| app s t => andb (bound k s) (bound k t)
| lambda s => bound (S k) s
end.

Definition closed s := bound 0 s = true.
Definition proc s := closed s /\ lam s.

Lemma bound_ge k s : bound k s = true -> forall m, m >= k -> bound m s = true.
Proof.
  revert k; induction s; cbn; intros.
  - unfold bound in *. decide (n < k); decide (n < m); try congruence. omega.
  - eapply Bool.andb_true_iff in H as []. erewrite IHs1, IHs2; eauto.
  - eapply IHs. eassumption. omega.
Qed.

Lemma bound_closed_k s k n u : bound n s = true -> k >= n -> subst s k u = s.
Proof with eauto.
  revert k n; induction s; intros; cbn.
  - decide (n = k)... subst. unfold bound in H. decide (k < n0). omega. congruence.
  - cbn in H. eapply Bool.andb_true_iff in H as []. erewrite IHs1, IHs2...
  - erewrite IHs... omega.
Qed.

Lemma closed_subst s k u : closed s -> subst s k u = s.
Proof.
  intros. eapply bound_ge in H. eapply bound_closed_k in H; eauto. omega.
Qed.

Lemma closed_app s t : closed (s t) -> closed s /\ closed t.
Proof.
  intros cls. now eapply Bool.andb_true_iff in cls.
Qed.

Lemma app_closed s t : closed s -> closed t -> closed (s t).
Proof.
  unfold closed. cbn. now intros -> ->.
Qed.

(** ** Named procedures *)

Definition I : term := .\"x"; "x".
Definition T : term := .\"x","y"; "x".
Definition F : term := .\"x","y"; "y".

Definition omega : term := .\"x"; "x" "x".
Definition Omega := omega omega.
Definition D: term := lambda (omega omega).

(** ** Evaluation relation *)

Inductive evaluates : term -> term -> Prop :=
  evaluates_lam s : evaluates (lambda s) (lambda s)
| evaluates_app s t u v w : evaluates s (lambda u) -> evaluates t v -> evaluates (subst u 0 v) w ->
                            evaluates (s t) w.
Hint Constructors evaluates.

Notation "s '▷' t" := (evaluates s t) (at level 50).

Definition eva s := exists t, evaluates s t.
Hint Unfold eva.

Lemma evaluates_abst s t : s ▷ t -> lam t.
Proof.
  induction 1; eauto.
Qed.

Lemma evaluates_functional s t1 t2 :
  s ▷ t1 -> s ▷ t2 -> t1 = t2.
Proof.
  intros H. revert t2. induction H; intros.
  - now inv H.
  - inv H2. eapply IHevaluates3.
    eapply IHevaluates1 in H5. inv H5.
    eapply IHevaluates2 in H6. inv H6.
    eassumption.
Qed.

(* Counterexample to Fact 5.2 *)

Lemma evaluates_bound : ~ forall s t n, s ▷ t -> bound n s = true -> bound n t = true.
Proof.
  intros H. specialize (H ((lambda (lambda 2)) (lambda 1)) (lambda 2) 1).
  cbn in H. eapply Bool.diff_false_true, H; eauto.
  repeat econstructor.
Qed.

Lemma bound_subst s t k : bound (S k) s = true -> bound k t = true -> bound k (subst s k t) = true.
Proof.
  revert k t; induction s; intros k t cls_s cls_t; cbn.
  - decide (n = k). subst. eauto. unfold bound in cls_s.
    decide (n < S k). unfold bound. decide (n < k). reflexivity. omega. congruence.
  - cbn in cls_s. eapply Bool.andb_true_iff in cls_s as []. rewrite IHs1, IHs2; eauto.
  - cbn in cls_s. rewrite IHs; eauto. eapply bound_ge; eauto.
Qed.

Lemma evaluates_closed s t : s ▷ t -> closed s -> closed t.
Proof.
  induction 1; cbn; intros.
  - eauto.
  - unfold closed in H2. cbn in H2. eapply Bool.andb_true_iff in H2 as [].
    firstorder using bound_subst.
Qed.

Lemma app_eva s t : eva (s t) -> eva s /\ eva t.
Proof.
  inversion 1. inv H0. firstorder.
Qed.

Lemma F_eva s t : eva (F s t) <-> eva s /\ eva t.
Proof.
  intuition.
  - now eapply app_eva in H as (H % app_eva & ?).
  - now eapply app_eva in H.
  - destruct H0, H1. exists x0. econstructor. econstructor. econstructor.
    eassumption. econstructor. eassumption. cbn. eapply evaluates_abst in H0. firstorder. subst.
    econstructor.
Qed.

Lemma F_correct s t : lam s -> lam t -> F s t ▷ t.
Proof.
  intros [? ->] [? ->]. repeat econstructor.
Qed.

Lemma eva_Omega : ~ eva Omega.
Proof.
  inversion 1. remember Omega as Om. induction H0; inv HeqOm.
  inv H0_. inv H0_0. cbn in H0_1. eapply IHevaluates3.
  cbn. reflexivity. eassumption.
Qed.

Lemma eva_D s : ~ eva (D s).
Proof.
  inversion 1. inversion H0. inv H3. cbn in H6.
  eapply eva_Omega. exists x. eassumption.
Qed.

Lemma evaluates_D s v : D s ▷ v <-> False.
Proof.
  firstorder using eva_D.
Qed.

(** * Uniformly confluent reduction semantics *)

(** ** One-step reduction *)
Reserved Notation "s '≻' t" (at level 50).

Inductive step : term -> term -> Prop :=
| stepApp  s t     : app (lambda s) (lambda t) ≻ subst s 0 (lambda t)
| stepAppR s t  t' : t ≻ t' -> app s t ≻ app s t'
| stepAppL s s' t  : s ≻ s' -> app s t ≻ app s' t
where "s '≻' t" := (step s t).

Hint Constructors step.

Ltac inv_step :=
  match goal with
  | H : step (app _ _) _ |- _ => inv H
  | H : step (lambda _) _ |- _ => inv H
  | H : step (var _) _ |- _ => inv H
  end.

(** ** Reflexive-transitive closure and step-indexed closure *)

Inductive star : term -> term -> Prop :=
  star_refl s : star s s
| star_step s u t : step s u -> star u t -> star s t.

Inductive stepn : nat -> term -> term -> Prop :=
  stepn_refl s : stepn 0 s s
| stepn_step s u t n : step s u -> stepn n u t -> stepn (S n) s t.

Hint Constructors step star stepn evaluates.

Instance star_trans : Transitive star.
Proof.
  intros s t u H1 H2. induction H1; eauto.
Qed.

Notation "s '≻*' t" := (star s t) (at level 40).
Notation "s '≻^' n t" := (stepn n s t) (at level 40, n at level 5).

Instance star_app : Proper (star ==> star ==> star) app.
Proof.
  intros s s' H t t' H1.
  induction H; intros; eauto.
  induction H1; eauto.
Qed.

Lemma star_stepn s t : s ≻* t <-> exists n, stepn n s t.
Proof.
  split; intros H.
  - induction H; eauto.
    destruct IHstar. eauto.
  - destruct H. induction H; eauto.
Qed.

Lemma evaluates_star s t : s ▷ t -> s ≻* t /\ lam t.
Proof.
  split.
  - induction H; eauto.
    eapply evaluates_abst in H0 as []. subst.
    rewrite star_app; eauto.
  - now eapply evaluates_abst in H.
Qed.

Lemma step_evaluates s s' t : s ≻ s' -> s' ▷ t -> s ▷ t.
Proof.
  intros H; revert t; induction H; intros; try inv H0; eauto.
Qed.

Lemma steps_evaluates s s' t : s ≻* s' -> s' ▷ t -> s ▷ t.
Proof.
  induction 1; eauto using step_evaluates.
Qed.

Lemma star_evaluates s t : s ≻* t -> lam t -> s ▷ t.
Proof.
  induction 1; inversion 1; subst; eauto using step_evaluates.
Qed.

Lemma stepn_plus s s' t n m : s ≻^n s' -> s' ≻^m t -> s ≻^(n+m) t.
Proof.
  induction 1; cbn; intros; eauto.
Qed.

Instance star_PreOrder : PreOrder star.
Proof.
  constructor; hnf; eauto using star_trans.
Qed.

(** ** Recursion operator *)

Definition C := .\ "x", "y"; "y" (.\ "z"; "x" "x" "y" "z").
Definition rho s : term := Eval cbv in .\ "x" ; C C !s "x".

Lemma rho_lam s : lam (rho s).
Proof.
  unfold rho. firstorder.
Qed.

Lemma rho_closed s : closed s -> closed (rho s).
Proof.
  unfold rho, C, closed. cbn. intros. eapply bound_ge in H. now rewrite H. omega.
Qed.

Lemma rho_correct u v : proc u -> proc v -> rho u v ≻^3 u (rho u) v.
Proof.
  intros [? [? H1]] [? [? H2]]; rewrite H1 , H2.
  do 2 econstructor. rewrite <- H1. cbn. rewrite closed_subst; eauto.
  rewrite H1. cbn. eauto.
Qed.

Lemma uniform_confluence s t1 t2 :
  s ≻ t1 -> s ≻ t2 -> t1 = t2 \/ exists u, t1 ≻ u /\ t2 ≻ u.
Proof with try subst; repeat inv_step; eauto 10 using step.
  intros Hst1. revert t2. induction Hst1; intros t2 Ht2...
  - destruct (IHHst1 _ H2)... destruct H as (? & [])...
  - destruct (IHHst1 _ H2)... destruct H as (? & [])...
Qed.

Lemma parametric_semi_confluence s t1 t2 n :
  s ≻ t1 -> s ≻^n t2 -> exists k l u, k <= n /\ l <= 1 /\ t1 ≻^k u /\ t2 ≻^l u /\ 1 + k = n + l.
Proof.
  revert s t1 t2; induction n; intros; inv H0.
  - exists 0, 1, t1; eauto 9.
  - destruct (uniform_confluence H H2) as [-> | (u' & ? & ?) ]; eauto 10.
    destruct (IHn _ _ _ H1 H3) as (k' & l' & u'' & ? & ? & ? & ? & ?).
    exists (S k'), l', u''. repeat split; eauto; omega.
Qed.

Lemma parametric_confluence s t1 t2 m n :
  s ≻^m t1 -> s ≻^n t2 -> exists k l u, k <= n /\ l <= m /\ t1 ≻^k u /\ t2 ≻^l u /\ m + k = n + l.
Proof.
  revert s t1 t2 n; induction m; intros; inv H.
  - exists n, 0, t2. eauto.
  - destruct (parametric_semi_confluence H2 H0) as (k & l & u' & ? & ? & ? & ? & ?).
    destruct (IHm _ _ _ _ H3 H4) as (k' & l' & u'' & ?  & ? & ? & ? & ?).
    exists k', (l + l'), u''. repeat split; eauto using stepn_plus; try omega.
Qed.

Lemma confluence s t1 t2 : s ≻* t1 -> s ≻* t2 -> exists u, t1 ≻*u /\ t2 ≻* u.
Proof.
  intros [] % star_stepn [] % star_stepn.
  edestruct (parametric_confluence H H0) as (k & l & u & ? & ? & ? & ? & ?).
  exists u. split; eapply star_stepn; eauto.
Qed.

Definition evaluatesin n s t := (s ≻^n t /\ lam t).
Notation "s '▷^' n t" := (evaluatesin n s t) (at level 40, n at level 5).

Definition stepplus s t := (exists s', s ≻ s' /\ s' ≻* t).
Notation "s '≻^+' t" := (stepplus s t) (at level 40).

Lemma unique_step_index s m t n : s ▷^m t -> s ▷^n t -> m = n.
Proof.
  intros (? & ? & ->) [].
  destruct (parametric_confluence H H0) as (k & l & u & ? & ? & ? & ? & ?).
  inv H4; inv H5; [ omega | inv_step.. ].
Qed.

Lemma stepplus_stepn s t : s ≻^+ t <-> exists n, s ≻^(S n) t.
Proof.
  intuition.
  - destruct H as ( ? & ? & (? & ?) % star_stepn). eauto.
  - destruct H as (? & ?). inv H.
    econstructor. split. eassumption. eapply star_stepn. eauto.
Qed.

Lemma triangle s n t s' : s ▷^n t -> s ≻^+ s' -> exists k, k < n /\ s' ▷^k t.
Proof.
  intros (? & ? & ->) [] % stepplus_stepn.
  destruct (parametric_confluence H H0) as (k & l & u & ? & ? & ? & ? & ?).
  inv H3. exists l. firstorder. inv_step.
Qed.

Instance step_star_subrelation : subrelation step star.
Proof.
  cbv. eauto.
Qed.

Instance stepplus_star_subrelation : subrelation stepplus star.
Proof.
  cbv. intros. destruct H as (? & ? & ?). eauto.
Qed.

(** ** Reduction equivalence *)

Reserved Notation "s '≡' t" (at level 50).

Inductive equiv : term -> term -> Prop :=
  | eqStep s t : step s t -> s ≡ t
  | eqRef s : s ≡ s
  | eqSym s t : t ≡ s -> s ≡ t
  | eqTrans s t u: s ≡ t -> t ≡ u -> s ≡ u
where "s '≡' t" := (equiv s t).

Hint Constructors equiv.

(* *** Properties of the equivalence relation *)

Instance equiv_Equivalence : Equivalence equiv.
Proof.
  constructor; hnf.
  - apply eqRef.
  - intros. eapply eqSym. eassumption.
  - apply eqTrans.
Qed.

Lemma star_equiv s t : s ≻* t -> s ≡ t.
Proof.
  induction 1; eauto.
Qed.

Lemma church_rosser s t : s ≡ t -> exists u, s ≻* u /\ t ≻* u.
Proof.
  induction 1; firstorder eauto. destruct (confluence H1 H4) as (? & ? & ?). eauto using star_trans.
Qed.

Instance app_equiv : Proper (equiv ==> equiv ==> equiv) app.
Proof with eauto.
  intros s s' H.
  induction H; intros ? ??...
  - eapply eqTrans. eapply eqStep. eapply stepAppL. eassumption.
    induction H0...
  - induction H...
Qed.

Lemma equiv_star_lam s t : lam t -> s ≡ t <-> s ≻* t.
Proof.
  intros. split; eauto using star_equiv.
  intros. eapply church_rosser in H0 as (u & H1 & H2). inv H2; eauto.
  inv H. inv_step.
Qed.

Lemma unique_normal_forms (s t : term) : lam s -> lam t ->  s ≡ t -> s = t.
Proof.
  intros ls lt H % equiv_star_lam; eauto. inv ls. inv H. reflexivity. inv H0.
Qed.

Lemma evaluates_equiv s t : s ▷ t <-> s ≡ t /\ lam t.
Proof with eauto using star_equiv, evaluates_abst.
  firstorder...
  - eapply evaluates_star in H as []...
  - eapply star_evaluates... eapply equiv_star_lam...
Qed.

Lemma equiv_evaluates s t v : s ≡ t -> s ▷ v -> t ▷ v.
Proof.
  intros. eapply evaluates_star in H0 as [].
  eapply church_rosser in H as (? & ? & ?).
  destruct (confluence H0 H) as (? & ? & ?). destruct H1; subst. inv H3.
  eauto using star_evaluates, star_trans. inv H1.
Qed.

Instance evaluates_proper :
  Proper (equiv ==> eq ==> iff) evaluates.
Proof.
  intros ? ? ? ? ? ?. subst. firstorder using equiv_evaluates.
Qed.

Instance eva_proper :
  Proper (equiv ==> iff) eva.
Proof.
  intros ? ? ?. firstorder. rewrite H in H0; firstorder. rewrite <- H in H0; firstorder.
Qed.

Lemma equiv_eva s t : s ≡ t -> eva s <-> eva t.
Proof.
  firstorder using equiv_evaluates; exists x; firstorder using equiv_evaluates.
Qed.

Instance evaluates_equiv_subrelation : subrelation evaluates equiv.
Proof.
  intros ? ? ?. now eapply evaluates_equiv.
Qed.

Instance star_equiv_subrelation : subrelation star equiv.
Proof.
  cbv. apply star_equiv.
Qed.

Instance stepplus_equiv_subrelation : subrelation stepplus equiv.
Proof.
  cbv. intros. eapply star_equiv. eapply stepplus_star_subrelation. eauto.
Qed.

Instance evaluatesin_equiv_subrelation n : subrelation (evaluatesin n) equiv.
Proof.
  intros ? ? ?. destruct H. eapply star_equiv_subrelation.
  eapply star_stepn. firstorder.
Qed.

Lemma stepplus_star_stepplus s s' t : s ≻^+ s' -> s' ≻* t ->  s ≻^+ t.
Proof.
  intros [? []] ?. exists x. eauto using star_trans.
Qed.

Lemma I_neq_Omega : ~ I ≡ Omega.
Proof.
  intros H. eapply eva_Omega. rewrite <- H. cbv. eauto.
Qed.