Unset Kernel Term Sharing.

(** * Construction of the circle *)

(** We will show that [B ℤ] has the universal property of the circle. *)

Require Import UniMath.Foundations.All.

Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.Algebra.Monoids.
Require Import UniMath.Algebra.Groups.

Require Import UniMath.NumberSystems.Integers
               UniMath.SyntheticHomotopyTheory.AffineLine
               UniMath.Algebra.GroupAction
               UniMath.MoreFoundations.MoreEquivalences.
Declare Scope paths_scope.
Delimit Scope paths_scope with paths.
Local Open Scope paths_scope.
Local Open Scope action_scope.

Local Notation "g + x" := (ac_mult _ g x) : action_scope.

Definition circle := B ℤ.

Theorem loops_circle : ℤ ≃ Ω circle.
Proof.
  apply loopsBG.
Defined.

Local Open Scope hz.

Definition circle_loop := ! loops_circle 1 : Ω circle.

Lemma loop_compute t : castTorsor (!circle_loop) t = one + t.
Proof.
  intros. unfold circle_loop. rewrite pathsinv0inv0.
  exact (loopsBG_comp_2 _ one t @ commax _ t one).
Defined.

(** ** The total space of guided homotopies over BZ *)

Definition ZGuidedHomotopy {Y} {y:Y} (l:y = y) (T:Torsor ℤ) :=
  GuidedHomotopy (confun T l).

Definition GH {Y} {y:Y} (l:y = y) := ∑ T:Torsor ℤ, ZGuidedHomotopy l T.

Definition make_GH {Y} {y:Y} (l:y = y) (T:Torsor ℤ) (g:ZGuidedHomotopy l T) :=
  T,,g : GH l.

Definition pr1_GH {Y} {y:Y} {l:y = y} := pr1 : GH l -> Torsor ℤ.

Definition pr2_GH {Y} {y:Y} (l:y = y) (u:GH l)
  := pr2 u : ZGuidedHomotopy l (pr1_GH u).

Definition GH_path3 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} {y':Y}
           {g g':GHomotopy (confun T l) y'} (u:g = g') :
  make_GH l T (y',, g) = make_GH l T (y',,g').
Proof.
  intros. destruct u. reflexivity.
Defined.

Definition pr12_GH {Y} {y:Y} {l:y = y} (u:GH l) := pr1 (pr2_GH l u) : Y.

Definition pr22_GH {Y} {y:Y} {l:y = y} (u:GH l)
     := pr2 (pr2_GH l u)
     : GHomotopy (confun (pr1_GH u) l) (pr12_GH u).

Definition GH_path3_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} {y':Y}
           {g g':GHomotopy (confun T l) y'} (u:g = g') :
  maponpaths pr1_GH (GH_path3 l u) = idpath T.
Proof.
  intros. destruct u. reflexivity.
Defined.

Definition GH_path3_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} {y':Y}
           {g g':GHomotopy (confun T l) y'} (u:g = g') :
  maponpaths pr12_GH (GH_path3 l u) = idpath y'.
Proof.
  intros. destruct u. reflexivity.
Defined.

Local Definition irr {Y} {y:Y} (l:y = y) (T:Torsor ℤ) :
  ∏ (v w : GuidedHomotopy (confun T l)), v = w
  :=
    (λ v w, proofirrGuidedHomotopy v w).

Local Definition sec {Y} {y:Y} (l:y = y) (T:Torsor ℤ) := makeGuidedHomotopy2 (confun T l).

Definition pr1_GH_weq {Y} {y:Y} {l:y = y} : (GH l) ≃ (Torsor ℤ) := weqpr1_irr_sec (irr l) (sec l).

Definition homotinvweqweq_GH_comp {Y} {y:Y} {l:y = y}
           (T:Torsor ℤ) (gh:ZGuidedHomotopy l T) :
  @paths (@paths (GH l)
             (invweq (@pr1_GH_weq _ _ l) T) (T,,gh))
            (homotinvweqweq' (irr l) (sec l) (T,,gh))
            (@pair_path_in2 _ (ZGuidedHomotopy l)
                            _ (sec l T) gh
                            (irr l T (sec l T) gh)).
Proof.
  reflexivity.             (* don't change the proof *)
Defined.

Definition makeGH {Y} {y:Y} (l:y = y) (T:Torsor ℤ) (t:T) {y':Y} (h:y' = y) : GH l
  := make_GH l T (makeGuidedHomotopy (t0:=t) _ h).

Definition makeGH1 {Y} {y:Y} (l:y = y) (T:Torsor ℤ) (t:T) : GH l
  := makeGH l T t (idpath y).

Definition pr12_pair_path_in2 {Y} {y:Y} (l:y = y) (T:Torsor ℤ)
           {gh gh':ZGuidedHomotopy l T} (w : gh = gh') :
  maponpaths pr12_GH (pair_path_in2 (ZGuidedHomotopy l) w) = maponpaths pr1 w.
Proof.
  intros. destruct w. reflexivity.
Defined.

Definition pr1_GH_weq_compute {Y} {y:Y} (l:y = y) :
  let T0 := trivialTorsor ℤ in
  let t0 := 0 : T0 in
    @paths (y = y)
              (maponpaths pr12_GH (homotinvweqweq' (irr l) (sec l) (makeGH1 l T0 t0)))
              (idpath y).
Proof.
  intros.
  unfold makeGH1,makeGH,make_GH.
  refine (maponpaths (maponpaths pr12_GH)
                     (homotinvweqweq_GH_comp
                        T0
                        (makeGuidedHomotopy (confun T0 l) (idpath y)))
                     @ _).
  refine (pr12_pair_path_in2
            l T0
            (irr l T0 (sec l T0)
                 (makeGuidedHomotopy (confun T0 l) (idpath y)))
            @ _).
  unfold sec.
  change (makeGuidedHomotopy (confun T0 l) (idpath y)) with (sec l T0).
  change (makeGuidedHomotopy2 (confun T0 l)) with (sec l T0).
  change (idpath y) with (maponpaths pr1 (idpath (sec l T0))).
  apply (maponpaths (maponpaths pr1)). apply irrel_paths. apply (irr l).
Defined.

(** ** Various paths in GH *)

Definition makeGH_localPath {Y} {y:Y} (l:y=y) (T:Torsor ℤ) {t t':T} (r:t = t')
           {y'} {h h':y' = y} (q:h = h')
  : makeGH l T t h = makeGH l T t' h'.
Proof.
  intros. destruct q, r. reflexivity.
  (* compare with [makeGuidedHomotopy_localPath] *)
Defined.

Definition makeGH_localPath_comp1 {Y} {y:Y} (l:y = y) (T:Torsor ℤ) {t t':T} (r:t = t')
           {y'} {h h':y' = y} (q:h = h') :
  maponpaths pr1_GH (makeGH_localPath l T r q) = idpath T.
Proof.
  intros. destruct q,r. reflexivity.
Defined.

Definition makeGH_localPath_comp2 {Y} {y:Y} (l:y = y) (T:Torsor ℤ) {t t':T} (r:t = t')
           {y'} {h h':y' = y} (q:h = h') :
  maponpaths pr12_GH (makeGH_localPath l T r q) = idpath y'.
Proof.
  intros. destruct q,r. reflexivity.
Defined.

Definition makeGH_verticalPath {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T)
           {y' y''} (h:y' = y) (p:y'' = y')
  : makeGH l T t (p@h) = makeGH l T t h.
Proof.
  intros. destruct p. reflexivity.
Defined.
(* could also use [makeGuidedHomotopy_verticalPath] *)

Definition makeGH_verticalPath_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T)
           {y' y''} (h:y' = y) (p:y'' = y')
  : maponpaths pr1_GH (makeGH_verticalPath l t h p) = idpath T.
Proof.
  intros. destruct p. reflexivity.
Defined.

Definition makeGH_verticalPath_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T)
           {y' y''} (h:y' = y) (p:y'' = y')
  : maponpaths pr12_GH (makeGH_verticalPath l t h p) = p.
Proof.
  intros. destruct p. reflexivity.
Defined.

Definition makeGH_horizontalPath {Y} {y:Y} (l:y = y) {T T':Torsor ℤ} (q:T = T')
           (t:T) {y'} (h:y' = y)
  : makeGH l T t h = makeGH l T' (castTorsor q t) h.
Proof.
  intros. destruct q. reflexivity.
  (* compare with [makeGuidedHomotopy_horizontalPath] *)
Defined.

Definition makeGH_horizontalPath_comp1 {Y} {y:Y} (l:y = y) {T T':Torsor ℤ} (q:T = T')
           (t:T) {y'} (h:y' = y)
  : maponpaths pr1_GH (makeGH_horizontalPath l q t h) = q.
Proof.
  intros. destruct q. reflexivity.
Defined.

Definition makeGH_horizontalPath_comp2 {Y} {y:Y} (l:y = y) {T T':Torsor ℤ} (q:T = T')
           (t:T) {y'} (h:y' = y)
  : maponpaths pr12_GH (makeGH_horizontalPath l q t h) = idpath y'.
Proof.
  intros. destruct q. reflexivity.
Defined.

Local Open Scope action_scope.

Definition makeGH_transPath {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y'} (h:y' = y)
  : makeGH l T t h = makeGH l T (one+t) (h@l).
Proof.
  intros. apply GH_path3.
  (* copied from the proof of [makeGuidedHomotopy_transPath] *)
  exact (ℤTorsorRecursion_transition_inv (λ _, weq_pathscomp0r _ l) (t:=t) h).
Defined.

Definition makeGH_transPath_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y'} (h:y' = y)
  : maponpaths pr1_GH (makeGH_transPath l t h) = idpath T.
Proof.
  intros. exact (GH_path3_comp1 l _).
Defined.

Definition makeGH_transPath_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T) {y'} (h:y' = y)
  : maponpaths pr12_GH (makeGH_transPath l t h) = idpath y'.
Proof.
  intros. exact (GH_path3_comp2 l _).
Defined.

Definition makeGH_diagonalLoop {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T)
           (q:T = T) (r:castTorsor q t = one + t) :
  makeGH1 l T t = makeGH1 l T t.
Proof.
  intros.
  assert (p2 := makeGH_transPath l t (idpath y)).
  assert (p0:= makeGH_localPath l T (!r) (idpath l)); clear r.
  assert (ph := makeGH_horizontalPath l q t l).
  assert (p1 := makeGH_localPath l T (idpath t) (! pathscomp0rid l)).
  assert (pv := makeGH_verticalPath l t (idpath y) l).
  assert (p := p2 @ p0 @ !ph @ p1 @ pv); clear p2 p0 ph p1 pv.
  exact p.
Defined.

Definition makeGH_diagonalLoop_comp1 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T)
           (q:T = T) (r:castTorsor q t = one + t) :
  maponpaths pr1_GH (makeGH_diagonalLoop l t q r) = !q.
Proof.
  intros. unfold makeGH_diagonalLoop.
  refine (maponpaths_naturality (makeGH_transPath_comp1 _ _ _) _).
  refine (maponpaths_naturality (makeGH_localPath_comp1 _ _ _ _) _).
  rewrite <- (pathscomp0rid (paths_rect _ _ (λ b _, b = T) _ _ q)). (* Used to be "rewrite <- (pathscomp0rid (! q))", which was more perspicuous. *)
  refine (maponpaths_naturality' (makeGH_horizontalPath_comp1 _ _ _ _) _).
  rewrite <- (pathscomp0rid (idpath T)).
  refine (maponpaths_naturality (makeGH_localPath_comp1 _ _ _ _) _).
  exact (makeGH_verticalPath_comp1 _ _ _ _).
Defined.

Definition makeGH_diagonalLoop_comp2 {Y} {y:Y} (l:y = y) {T:Torsor ℤ} (t:T)
           (q:T = T) (r:castTorsor q t = one + t) :
  maponpaths pr12_GH (makeGH_diagonalLoop l t q r) = l.
Proof.
  intros. unfold makeGH_diagonalLoop.
  refine (maponpaths_naturality (makeGH_transPath_comp2 _ _ _) _).
  refine (maponpaths_naturality (makeGH_localPath_comp2 _ _ _ _) _).
  refine (maponpaths_naturality' (makeGH_horizontalPath_comp2 _ _ _ _) _).
  refine (maponpaths_naturality (makeGH_localPath_comp2 _ _ _ _) _).
  exact (makeGH_verticalPath_comp2 _ _ _ _).
Defined.

(** ** The universal property of the circle *)

(** *** The recursion principle (non-dependent functions) *)

Definition circle_map {Y} {y:Y} (l:y = y) : circle -> Y.
Proof.
  exact (funcomp (invmap (@pr1_GH_weq _ _ l)) pr12_GH).
Defined.

Definition circle_map_check_values {Y} {y:Y} (l:y = y) :
  circle_map l (basepoint circle) = y.
Proof.
  reflexivity.
  (* don't change the proof *)
  (* This proof works because the trivial torsor has an actual point that provides the accompanying proof of nonemptiness. *)
Defined.

Definition circle_map_check_paths {Y} {y:Y} (l:y = y) :
  maponpaths (circle_map l) circle_loop = l.
Proof.
  intros. assert (p := pr1_GH_weq_compute l).
  refine (_ @ loop_correspondence' (irr l) (sec l) pr12_GH
            (makeGH_diagonalLoop_comp1 l _ _ (loop_compute 0))
            (makeGH_diagonalLoop_comp2 l _ _ (loop_compute 0)) @ _).
  { intermediate_path (maponpaths (circle_map l) circle_loop @ idpath y).
    { apply pathsinv0. apply pathscomp0rid. }
    { apply pathsinv0. rewrite pathsinv0inv0.
      exact (maponpaths (λ r, maponpaths (circle_map l) circle_loop @ r) p). } }
  { exact (maponpaths (λ r, r @ l) p). }
Defined.

Definition circle_map_conjugation {Y} {y:Y} (l:y = y) {y':Y} (e:y=y') :
  circle_map l = circle_map (!e @ l @ e).
Proof.
  induction e.
  change (circle_map l = circle_map (l @ idpath y)).
  rewrite pathscomp0rid.
  reflexivity.
Defined.

(** *** The induction principle (dependent functions) *)

Local Open Scope transport.

Definition CircleInduction : Type
  := ∏ (Y:circle->Type) (y:Y(basepoint circle)) (l:circle_loop#y = y),
     ∏ c:circle, Y c.

Definition circle_map' : CircleInduction.
Proof.
  (** (not proved yet) *)
Abort.

(* One approach to the theorem above would be through the results of the paper
 "Higher Inductive Types as Homotopy-Initial Algebras", by Kristina Sojakova,
 http://arxiv.org/abs/1402.0761 *)

Section A.

  Context (circle_map': CircleInduction).

  Lemma circle_map_check_paths' {Y} (f:circle->Y) : circle_map (maponpaths f circle_loop) = f .
  Proof.
    intros. apply funextsec.
    simple refine (circle_map' _ _ _).
    { reflexivity. }
    { set (y := f (basepoint circle)). set (l := maponpaths f circle_loop).
      set (P := λ T : underlyingType circle, circle_map _ T = f T).
      apply transport_fun_path. rewrite pathscomp0rid.
      change (idpath y @ maponpaths f circle_loop) with (maponpaths f circle_loop).
      exact (! circle_map_check_paths l). }
  Defined.

  Lemma circle_map_uniqueness {Y} (f g:circle->Y)
        (e : f (basepoint circle) = g (basepoint circle))
        (q : maponpaths f circle_loop = e @ maponpaths g circle_loop @ !e):
    f = g.
  Proof.
  Abort.

  Definition circle_map'' : CircleInduction.
  Proof.
    (** (not proved yet) *)
  Abort.

End A.

(*
Local Variables:
compile-command: "make -C ../.. UniMath/SyntheticHomotopyTheory/Circle.vo"
End:
*)


Require Import Braun.monad.monad Braun.common.util Braun.common.le_util.
Require Import Braun.common.big_oh Braun.common.braun.
Require Import Braun.make_array.take_drop_split.
Require Import Arith Arith.Le Arith.Lt Peano Arith.Min.
Require Import Coq.Arith.Compare_dec.
Require Import Program.Wf Init.Wf.

Include WfExtensionality.

Definition zip_with_3_bt_node_time len := 16 * len + 3.
Hint Unfold zip_with_3_bt_node_time.

Definition zip_with_3_bt_node_result
           (A:Set) (xs:list A)
           (ts1:list (@bin_tree A)) (ts2:list (@bin_tree A))
           (res:list (@bin_tree A)) c :=
  length xs <= length ts1 /\ length xs <= length ts2 ->
  c = zip_with_3_bt_node_time (length xs).
Hint Unfold zip_with_3_bt_node_result.

Load "zip_with_3_bt_node_gen.v".

Next Obligation.
Proof.
  unfold zip_with_3_bt_node_result.
  intros LENS.
  destruct LENS as [L1 L2].
  simpl in L1.
  intuition.
Qed.

Next Obligation.
Proof.
  unfold zip_with_3_bt_node_result.
  intros LENS.
  destruct LENS as [L1 L2].
  simpl in L2.
  intuition.
Qed.

Next Obligation.
Proof.
  clear am H1.
  rename H0 into ZWRES.

  unfold zip_with_3_bt_node_result in *.
  unfold zip_with_3_bt_node_time in *.
  simpl.
  omega.
Qed.

Lemma zip_with_3_bt_node_linear : big_oh zip_with_3_bt_node_time (fun n => n).
Proof.
  unfold zip_with_3_bt_node_time.
  auto.
Qed.

Definition build_time k len :=
  pad_drop_time (2*k) +
  split_time (2*k) k +
  zip_with_3_bt_node_time len +
  16.
Hint Unfold build_time.

Definition build_result
           (A:Set)
           (pr:nat * list A)
           (ts : list (@bin_tree A))
           (res : list (@bin_tree A))
           c :=
  (length (snd pr) <= fst pr) ->
  c = build_time (fst pr) (length (snd pr)).
Hint Unfold build_result.

Load "build_gen.v".

Next Obligation.
Proof.
  clear am am0 am1 H3 H4 H5.
  rename H0 into ZWres.
  rename H2 into PDres.
  rename H1 into SPLITres.
  unfold build_result.
  unfold build_time.
  unfold zip_with_3_bt_node_result in *.
  unfold pad_drop_result in *.
  unfold split_result in *.
  simpl in SPLITres.
  simpl.
  destruct SPLITres as [AN0eq [SHORT LONG]].
  clear SHORT.
  destruct PDres as [AN1eq LENpadded].
  rewrite LENpadded in *.
  replace (n + (n+0)-n) with n in LONG;[|omega].
  assert (length l = n /\ length l0 = n) as LENS;[apply LONG; omega|clear LONG].
  destruct LENS as [LENl LENl0].
  rewrite LENl in *.
  rewrite LENl0 in *.
  clear LENl LENl0.
  intros LENl1.
  assert (an = zip_with_3_bt_node_time (length l1));[apply ZWres; auto|].
  subst an1 an0 an.
  omega.
Qed.


From Common Require Export Literal Primitive.
From Utils Require Import Env Tactics.

Inductive atom := Var (n: nat) | Lit (lit: literal).

Inductive term :=
| LetB (name: nat) (op: binary_primitives) (a1 a2: atom) (rest: term)
| LetU (name: nat) (op: unary_primitives) (a: atom) (rest: term)
| LetC (cont: cnt) (rest: term)
| LetF (f: fnt) (rest: term)
| LetIn (name: nat) (rest: term)
| LetOut (n:nat) (a: atom) (rest: term) (* We need n (which is always unit) because Out returns unit *)
| AppC0 (name: nat)
| AppC1 (name: nat) (a: atom)
| AppF (f: atom) (retC: nat) (a: atom)
| Ite (c: atom) (thenC elseC: nat)
| Match (scrut: atom) (lc rc: nat)
| Halt (a: atom)
with
  cnt := Cnt0 (name: nat) (body: term) | Cnt1 (name arg: nat) (body: term)
with
  fnt := Fnt (name retC arg: nat) (body: term).

Definition nf_atom a :=
  match a with
  | Var n => S n
  | Lit _ => 0
  end.

Fixpoint next_free t :=
  match t with
  | LetB n _ a1 a2 r =>
      Nat.max (S n) (Nat.max (nf_atom a1) (Nat.max (nf_atom a2) (next_free r)))
  | LetU n _ a r =>
      Nat.max (S n) (Nat.max (nf_atom a) (next_free r))
  | LetC (Cnt0 n b) r =>
      Nat.max (S n) (Nat.max (next_free b) (next_free b))
  | LetC (Cnt1 n a b) r =>
      Nat.max (S n) (Nat.max (S a) (Nat.max (next_free b) (next_free r)))
  | LetF (Fnt n c a b) r =>
      Nat.max (S n) (Nat.max (S c) (Nat.max (S a) (Nat.max (next_free b) (next_free r))))
  | LetIn n r =>
      Nat.max (S n) (next_free r)
  | LetOut n a r =>
      Nat.max (S n) (Nat.max (nf_atom a) (next_free r))
  | AppC0 n => S n
  | AppC1 n a => Nat.max (S n) (nf_atom a)
  | AppF f c a => Nat.max (nf_atom f) (Nat.max (S c) (nf_atom a))
  | Ite c t e => Nat.max (nf_atom c) (Nat.max (S t) (S e))
  | Match s lc rc => Nat.max (nf_atom s) (Nat.max (S lc) (S rc))
  | Halt a => nf_atom a
  end.

Fixpoint size t :=
  match t with
  | LetB _ _ _ _ r => 1 + size r
  | LetU _ _ _ r => 1 + size r
  | LetC (Cnt0 _ b) r => 1 + size b + size r
  | LetC (Cnt1 _ _ b) r => 1 + size b + size r
  | LetF (Fnt _ _ _ b) r => 1 + size b + size r
  | LetIn _ r => 1 + size r
  | LetOut _ _ r => 1 + size r
  | AppC0 _ => 1
  | AppC1 _ _ => 1
  | AppF _ _ _ => 1
  | Ite _ _ _ => 1
  | Match _ _ _ => 1
  | Halt _ => 1
  end.

Lemma size_t_gt_1 : forall t, 0 < size t.
Proof.
  induction t; reduce; destruct_match; lia.
Qed.

Section Renameₜ.
  Variable e : env nat.

  Definition get_or_id (n : nat) :=
    match e ? n with
    | Some n => n
    | None => n
    end.

  Definition renameₐ (a : atom) :=
    match a with
    | Var n => Var (get_or_id n)
    | Lit _ => a
    end.

  Fixpoint renameₜ (t : term) :=
    match t with
    | LetB n op a1 a2 r =>
        let n := get_or_id n in
        let a1 := renameₐ a1 in
        let a2 := renameₐ a2 in
        let r := renameₜ r in
          LetB n op a1 a2 r
    | LetU n op a r =>
        let n := get_or_id n in
        let a := renameₐ a in
        let r := renameₜ r in
          LetU n op a r
    | LetC (Cnt0 n b) r =>
        let n := get_or_id n in
        let b := renameₜ b in
        let r := renameₜ r in
          LetC (Cnt0 n b) r
    | LetC (Cnt1 n a b) r =>
        let n := get_or_id n in
        let a := get_or_id a in
        let b := renameₜ b in
        let r := renameₜ r in
          LetC (Cnt1 n a b) r
    | LetF (Fnt n c a b) r =>
        let n := get_or_id n in
        let c := get_or_id c in
        let a := get_or_id a in
        let b := renameₜ b in
        let r := renameₜ r in
          LetF (Fnt n c a b) r
    | LetIn n r =>
        let n := get_or_id n in
        let r := renameₜ r in
          LetIn n r
    | LetOut n a r =>
        let n := get_or_id n in
        let a := renameₐ a in
        let r := renameₜ r in
          LetOut n a r
    | AppC0 n =>
        let n := get_or_id n in
          AppC0 n
    | AppC1 n a =>
        let n := get_or_id n in
        let a := renameₐ a in
          AppC1 n a
    | AppF f c a =>
        let f := renameₐ f in
        let c := get_or_id c in
        let a := renameₐ a in
          AppF f c a
    | Ite c t e =>
        let c := renameₐ c in
        let t := get_or_id t in
        let e := get_or_id e in
          Ite c t e
    | Match s lc rc =>
        let s := renameₐ s in
        let lc := get_or_id lc in
        let rc := get_or_id rc in
          Match s lc rc
    | Halt a =>
        let a := renameₐ a in
          Halt a
    end.
End Renameₜ.

Lemma get_or_id_empty : forall n,
  get_or_id { } n = n.
Proof. reduce. Qed.

Lemma rename_a_empty : forall a,
  renameₐ { } a = a.
Proof.
  destruct a; reduce.
Qed.

Lemma rename_t_empty_ind : forall n t, size t < n ->
  renameₜ { } t = t.
Proof.
  induction n, t; repeat reduce || destruct_match || simpl_lia.
  all: repeat rewrite get_or_id_empty || rewrite rename_a_empty; reduce.
  all: repeat rewrite IHn; auto with lia.
Qed.

Lemma rename_t_empty : forall t,
  renameₜ { } t = t.
Proof.
  eauto using rename_t_empty_ind.
Qed.


Require Import ND.
Require Import GenTarski.

(** ** Constructive Analysis *)

Definition stable P := ~ ~ P -> P.

Lemma stable_equiv P Q :
  P <-> Q -> stable P -> stable Q.
Proof.
  firstorder.
Qed.

Definition stab_class := forall Sigma, @theory Sigma -> Prop.
Definition map_closed (S : stab_class) {Sig Sig'} (f : @form Sig -> @form Sig') := forall T, S Sig T -> S Sig' (tmap f T).

Definition ST (S : stab_class) := forall Sigma T phi, S Sigma T -> stable (T ⊩CE phi).

Section PropT.
  Definition dummy_sig : Signature := {| Funcs := False; Preds := False; pred_ar := @except nat ; fun_ar := @except nat |}.

  Definition prop_T (P : Prop) := fun phi : @form dummy_sig => phi = ⊥ /\ P.

  Lemma prop_T_correct P :
    prop_T P ⊩CE ⊥ <-> P.
  Proof.
    split.
    - intros ([ | x] & HA1 & HA2). 1: contradiction (Consistency HA2).
      destruct (HA1 x (or_introl eq_refl)). firstorder.
    - exists [⊥]; split. 2: ctx. now intros ? [<- | []].
  Qed.

  Global Instance False_enumT : enumT False.
  Proof.
    exists (fun _ => []). 1: auto. intros [].
  Qed.
End PropT.

Section StabilityClasses.
  (** **** Double Negation Elimination *)

  Section DN.
    Definition DN := forall P, stable P.

    Definition any_T : stab_class := fun _ _ => True.
    Definition ST__a := ST any_T.

    Lemma any_T_map_closed {Sig Sig' : Signature} (f : @form Sig -> @form Sig') :
      map_closed any_T f.
    Proof.
      firstorder.
    Qed.

    Lemma dn_to_sta :
      DN -> ST__a.
    Proof.
      intros dn Sig T phi _. apply dn.
    Qed.

    Lemma sta_to_dn :
      ST__a -> DN.
    Proof.
      intros sta P. eapply stable_equiv. 1: apply (prop_T_correct P). now apply sta.
    Qed.
  End DN.

  (** **** Synthetic Markov's Principle *)

  Section SyntMP.
    Definition tsat (f : nat -> bool) := exists n, f n = true.
    Definition MP := forall f : nat -> bool, stable (tsat f).

    Definition enum_T : stab_class := fun _ T => exists (HdF : eq_dec Funcs) (HdP : eq_dec Preds)
                                                (HeF : enumT Funcs) (HeP : enumT Preds) L, enum T L.
    Definition ST__e := ST enum_T.

    Lemma enum_T_map_closed_closing {Sig : Signature} :
      @map_closed enum_T Sig (sig_ext Sig) (fun phi => (sig_lift phi)[ext_c]).
    Proof.
      intros T (? & ? & ? & ? & L & He). exists (dec_sig_ext_Funcs _), (dec_sig_ext_Preds _).
      exists (enumT_sig_ext_Funcs _), (enumT_sig_ext_Preds _), (L >> map (fun phi => (sig_lift phi)[ext_c])).
      now apply enum_tmap.
    Qed.

    Lemma enum_T_map_closed_homo {Sig : Signature} (f : @form Sig -> @form Sig) :
      map_closed enum_T f.
    Proof.
      intros T (HdF' & HdP' & HeF' & HeP' & L & He). exists HdF', HdP', HeF', HeP', (L >> map f).
      now apply enum_tmap.
    Qed.

    Section MPEnum.
      Hypothesis mp : MP.
      Variable (X : Type) (L : nat -> list X) (P : X -> Prop).
      Hypothesis (HL : enum P L) (HX : eq_dec X).

      Lemma enumeration_semi_decidable x :
        exists (f : nat -> bool), P x <-> tsat f.
      Proof.
        destruct HL as [_ H]. exists (fun n => if list_in_dec x (L n) HX then true else false).
        split.
        - intros [m ?] % H. exists m. now destruct (list_in_dec x (L m) HX).
        - intros [m Hm]. destruct (list_in_dec x (L m) HX) in Hm. 2: discriminate. firstorder.
      Qed.

      Lemma enumeration_stability x :
        stable (P x).
      Proof.
        intros Hn. destruct (enumeration_semi_decidable x) as [f Hf].
        apply Hf. apply mp. intros Hf'. apply Hn. intros [m Hm] % Hf. apply Hf'. now exists m.
      Qed.
    End MPEnum.

    Lemma mp_to_ste :
      MP -> ST__e.
    Proof.
      intros mp Sig T phi (? & ? & ? & ? & L & He).  apply (enumeration_stability mp (enum_tprv He) (dec_form _ _)).
    Qed.

    Fixpoint L_tsat_T (f : nat -> bool) (n : nat) : list (@form dummy_sig) :=
      match n with
      | 0 => []
      | S n => L_tsat_T f n ++ if f n then [⊥] else []
      end.

    Lemma enum_tsat_T (f : nat -> bool) :
      enum (prop_T (tsat f)) (L_tsat_T f).
    Proof.
      split. 1: eauto. split.
      - intros [-> [n H]]. exists (S n). cbn. rewrite H. now in_app 2.
      - intros [n]. induction n in x, H |-*; cbn in *. 1: contradiction. inv_collect.
        destruct (f n) eqn:Hf.
        + destruct H as [<- | []]. firstorder.
        + contradiction.
    Qed.

    Lemma ste_to_mp :
      ST__e -> MP.
    Proof.
      intros ste f. eapply stable_equiv. 1: apply prop_T_correct.
      apply ste. exists _, _, _, _, (L_tsat_T f). apply (enum_tsat_T f).
    Qed.
  End SyntMP.

  (** **** Object Markov's Principle *)

  Section ObjMP.
    Definition fin_T : stab_class := fun Sig T => exists A, forall phi, phi ∈ T <-> phi el A.
    Definition ST__f := ST fin_T.

    Lemma fin_T_map_closed {Sig Sig'} (f : @form Sig -> @form Sig') :
      map_closed fin_T f.
    Proof.
      intros T [A HA]. exists (map f A). intros phi. split.
      - intros (psi & Hpsi1 % HA & <-). now apply in_map.
      - intros (psi & <- & Hpsi) % in_map_iff. firstorder.
    Qed.

    Section ConT.
      Context {Sigma : Signature}.
      Context {p : peirce} {b : bottom}.

      Definition con_T A : theory := fun phi => phi el A.

      Lemma con_T_correct A phi :
         con_T A ⊩ phi <-> A ⊢ phi.
      Proof.
        firstorder. apply (Weak H0). firstorder.
      Qed.

      Lemma fin_T_con_T A :
        fin_T (con_T A).
      Proof.
        firstorder.
      Qed.
    End ConT.

    Lemma fin_T_to_context {Sig : Signature} T phi :
      fin_T T -> exists A, A ⊢CE phi <-> T ⊩CE phi.
    Proof.
      intros [A HA]. exists A. split.
      - intros; exists A; firstorder.
      - intros (B & HB1 & HB2). apply (Weak HB2). firstorder.
    Qed.

    Lemma stf_to_st_context :
      ST__f <-> (forall Sigma A (phi : @form Sigma), stable (A ⊢CE phi)).
    Proof.
      split.
      - intros stf Sig A phi. eapply stable_equiv. 1: apply con_T_correct.
        apply stf. apply fin_T_con_T.
      - intros stc Sig T phi HT. destruct (fin_T_to_context phi HT) as [A HA].
        eapply stable_equiv. apply HA. apply stc.
    Qed.
  End ObjMP.
End StabilityClasses.


Require Import FOL Peano Tarski Deduction CantorPairing NumberTheory Synthetic DecidabilityFacts.
Require Import Lia.
Require Import FOL Peano Tarski Deduction CantorPairing NumberTheory Formulas Synthetic DecidabilityFacts Coding.
Require Import Lia.

Section Model.

  Variable D : Type.
  Variable I : interp D.
  Notation "⊨ phi" := (forall rho, rho ⊨ phi) (at level 21).
  Variable axioms : forall ax, PA ax -> ⊨ ax.

  Notation "N⊨ phi" := (forall rho, @sat _ _ nat interp_nat _ rho phi) (at level 40).
  Notation "x 'i⧀' y" := (exists d : D, y = iσ (x i⊕ d) ) (at level 40).

  (*  The double negation ¬¬(A ∨ ¬A) of a LEM instance can be proven
      intuitionistically. This can be generalized to finitely many instances.
      So for example, given a predicate [p] over nat it is possible to show that
      B instances a provable:

      ¬¬( (p 0 ∨ ¬p 0) ∧ ... ∧ (p B ∨ ¬p B) )

      Properly written with a quantifier this is expressed by:

      ¬¬ ∀ x < S B. (p x ∨ ¬p x)

      In the following we show this for unary and binary formulas in
      models of PA and then apply it in the proof of a variant of
      Tennenbaum's Theorem.
   *)

  Lemma bounded_definite_unary'' ϕ :
    bounded 1 ϕ -> forall x, ~ ~ forall y, y i⧀ x -> (fun _ => y) ⊨ ϕ \/ ~ (fun _ => y) ⊨ ϕ.
  Proof.
    intros H1.
    pose (Φ := ¬¬ ∀ $0 ⧀ $1 --> ϕ ∨ ¬ ϕ).
    assert (forall d rho, (d .: rho) ⊨ Φ) as H.
    apply induction.
    - apply axioms.
    - repeat solve_bounds; eapply bounded_up; try apply H1; try lia.
    - intros rho. cbn. apply DN.
      now intros y Hy%nolessthen_zero.
    - intros x IHx rho. cbn -[Q] in *.
      specialize (IHx rho).
      assert (~~ ((x .: rho) ⊨ ϕ \/ ~ (x .: rho) ⊨ ϕ) ) as H' by tauto.
      apply (DN_chaining IHx), (DN_chaining H'), DN.
      intros H IH y.
      rewrite lt_S; auto.
      intros [LT| <-].
      + destruct (IH _ LT) as [h|h].
        * left. eapply bound_ext. apply H1. 2 : apply h.
          intros []; solve_bounds.
        * right. intros h1. apply h.
          eapply bound_ext. apply H1. 2 : apply h1.
          intros []; solve_bounds.
      + destruct H as [h|h].
        * left. eapply bound_ext. apply H1. 2 : apply h.
          intros []; solve_bounds.
        * right. intros h1. apply h.
          eapply bound_ext. apply H1. 2 : apply h1.
          intros []; solve_bounds.
    - intros x.
      specialize (H x (fun _ => i0)). cbn in H.
      apply (DN_chaining H), DN. clear H; intros H.
      intros y Hy. destruct (H _ Hy) as [h|h].
      + left. eapply bound_ext. apply H1. 2: apply h.
        intros []; solve_bounds.
      + right. intros G. apply h.
        eapply bound_ext. apply H1. 2: apply G.
        intros []; solve_bounds.
  Abort.

  Lemma bounded_definite_unary' ϕ rho :
    bounded 2 ϕ -> forall x b, ~ ~ forall y, y i⧀ x -> (y .: b .: rho) ⊨ ϕ \/ ~ (y .: b .: rho) ⊨ ϕ.
  Proof.
    intros b2.
    pose (Φ := ∀ ¬¬ ∀ $0 ⧀ $2 --> ϕ ∨ ¬ ϕ).
    assert (forall d rho, (d .: rho) ⊨ Φ) as H.
    apply induction.
    - apply axioms.
    - repeat solve_bounds; eapply bounded_up; try apply b2; try lia.
    - intros sigma b. cbn. apply DN.
      now intros y Hy%nolessthen_zero.
    - intros x IHx. cbn -[Q] in *.
      intros sigma b. specialize (IHx sigma b).
      assert (~~ ((x .: b .: b .: sigma) ⊨ ϕ \/ ~ (x .: b .: b .: sigma) ⊨ ϕ) ) as H' by tauto.
      apply (DN_chaining IHx), (DN_chaining H'), DN.
      intros H IH y.
      rewrite lt_S; auto.
      intros [LT| <-].
      + destruct (IH _ LT) as [h|h].
        * left. eapply bound_ext. apply b2. 2 : apply h.
          intros [|[]]; solve_bounds.
        * right. intros h1. apply h.
          eapply bound_ext. apply b2. 2 : apply h1.
          intros [|[]]; solve_bounds.
      + destruct H as [h|h].
        * left. eapply bound_ext. apply b2. 2 : apply h.
          intros [|[]]; solve_bounds.
        * right. intros h1. apply h.
          eapply bound_ext. apply b2. 2 : apply h1.
          intros [|[]]; solve_bounds.
    - intros x b.
      specialize (H x (fun _ => i0)). cbn in H.
      specialize (H b).
      apply (DN_chaining H), DN. clear H; intros H.
      intros y Hy. destruct (H _ Hy) as [h|h].
      + left. eapply bound_ext. apply b2. 2: apply h.
        intros [|[]]; solve_bounds.
      + right. intros G. apply h.
        eapply bound_ext. apply b2. 2: apply G.
        intros [|[]]; solve_bounds.
  Qed.

  Corollary bounded_definite_unary ϕ b rho x :
    bounded 2 ϕ -> ~ ~ forall y, y i⧀ x -> (y .: b .: rho) ⊨ ϕ \/ ~ (y .: b .: rho) ⊨ ϕ.
  Proof.
    intros b2; now apply bounded_definite_unary'.
  Qed.

  Lemma bounded_definite_binary ϕ :
    bounded 2 ϕ -> forall x, ~ ~ forall y z, y i⧀ x -> z i⧀ x -> (z .: fun _ => y) ⊨ ϕ \/ ~ (z .: fun _ => y) ⊨ ϕ.
  Proof.
    intros b2.
    pose (Φ := ¬¬ ∀∀ $0 ⧀ $2 --> $1 ⧀ $2 --> ϕ ∨ ¬ ϕ).
    assert (forall d rho, (d .: rho) ⊨ Φ) as H.
    apply induction. apply axioms.
    repeat solve_bounds; eapply bounded_up; try apply b2; try lia.
    - intros rho. cbn. intros nH. apply nH.
      now intros y z Hy%nolessthen_zero.
    - intros b IH rho. cbn -[Q] in *.
      specialize (IH rho).
      assert (~~ ((b .: b .: rho) ⊨ ϕ \/ ~ (b .: b .: rho) ⊨ ϕ) ) as Hbb by tauto.
      apply (DN_chaining IH), (DN_chaining Hbb).
      apply (DN_chaining (bounded_definite_unary _ b rho b b2)).
      refine (DN_chaining (bounded_definite_unary (ϕ[$1 ..] ) b rho b _) _).
      { eapply subst_bound; eauto.
        intros [|[]]; solve_bounds. }
      apply DN. clear IH Hbb.
      intros H1 H2 Hbb IH x y.
      rewrite !lt_S; try apply axioms.
      intros [lty| <-] [ltx| <-].
      + destruct (IH _ _ lty ltx) as [h|h].
        * left. eapply bound_ext. apply b2. 2 : apply h.
          intros [|[]]; solve_bounds.
        * right. intros h1. apply h.
          eapply bound_ext. apply b2. 2 : apply h1.
          intros [|[]]; solve_bounds.
      + destruct (H2 _ lty) as [h|h].
        * left. eapply bound_ext. apply b2. 2 : apply h.
          intros [|[]]; solve_bounds.
        * right. intros h1. apply h.
          eapply bound_ext. apply b2. 2 : apply h1.
          intros [|[]]; solve_bounds.
      + destruct (H1 _ ltx) as [h|h]; rewrite sat_comp in h.
        * left. eapply bound_ext. apply b2. 2 : apply h.
          intros [|[]]; solve_bounds.
        * right. intros h1. apply h.
          eapply bound_ext. apply b2. 2 : apply h1.
          intros [|[]]; solve_bounds.
      + destruct Hbb as [h|h].
        * left. eapply bound_ext. apply b2. 2 : apply h.
          intros [|[]]; solve_bounds.
        * right. intros h1. apply h.
        eapply bound_ext. apply b2. 2 : apply h1.
        intros [|[]]; solve_bounds.
      - intros x.
        specialize (H x (fun _ => i0)). cbn in H.
        apply (DN_chaining H), DN. clear H; intros H.
        intros y z Hy Hz. destruct (H _ _ Hz Hy) as [h|h].
        + left. eapply bound_ext. apply b2. 2: apply h.
          intros [|[]]; solve_bounds.
        + right. intros h1. apply h.
          eapply bound_ext. apply b2. 2: apply h1.
          intros [|[]]; solve_bounds.
  Qed.

  Definition div_num n (d : D) := exists e, inu n i⊗ e = d.
  Definition Div_nat (d : D) := fun n => div_num n d.

  Lemma DN_Div_nat :
    UC nat bool -> nonStd D -> forall d, ~~Dec (Div_nat d).
  Proof.
    intros uc [e He] d.
    refine (DN_chaining _ _).
    2 : { now apply DN, UC_Def_Dec. }
    refine (DN_chaining (bounded_definite_binary (∃ $1 ⊗ $0 == $2) _ (iσ (d i⊕ e))) _).
    { repeat solve_bounds. }
    apply DN. intros H n.
    destruct (H d (inu n)) as [h|h].
    - now exists e.
    - apply num_lt_nonStd; auto.
      rewrite <-add_rec; auto.
      intros h%std_add; auto.
      now apply He.
    - left. apply h.
    - right. apply h.
  Qed.

End Model.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** This file provides a constructive form of indefinite description that
    allows building choice functions; this is weaker than Hilbert's
    epsilon operator (which implies weakly classical properties) but
    stronger than the axiom of choice (which cannot be used outside
    the context of a theorem proof). *)

Require Import ChoiceFacts.

Set Implicit Arguments.

Axiom constructive_indefinite_description :
  forall (A : Type) (P : A->Prop),
    (exists x, P x) -> { x : A | P x }.

Lemma constructive_definite_description :
  forall (A : Type) (P : A->Prop),
    (exists! x, P x) -> { x : A | P x }.
Proof.
  intros; apply constructive_indefinite_description; firstorder.
Qed.

Lemma functional_choice :
  forall (A B : Type) (R:A->B->Prop),
    (forall x : A, exists y : B, R x y) ->
    (exists f : A->B, forall x : A, R x (f x)).
Proof.
  apply constructive_indefinite_descr_fun_choice.
  exact constructive_indefinite_description.
Qed.


Require Import compcert.lib.Integers.
Require Import Recdef.
Require Import List. Import ListNotations.
Require Import Arith.
Require Import compcert.lib.Coqlib.
Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.
Require Import sha.ByteBitRelations.
Require Import sha.HMAC_common_defs.

Require Import sha.SHA256.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC256_functional_prog.
Require Import sha.hmac_common_lemmas.

Require Import sha.pure_lemmas.
Require Import sha.sha_padding_lemmas.
Require Import VST.floyd.sublist. (*for Forall_list_repeat*)

Definition c := (32 * 8)%nat.
Definition p := (32 * 8)%nat.
Definition b := (c + p)%nat.
Definition BlockSize := 64.
Definition BlockSize_Bits := BlockSize * 8.

Definition sha_iv : Blist :=
  intsToBits SHA256.init_registers.

Definition sha_h (regs : Blist) (block : Blist) : Blist :=
  intsToBits (SHA256.hash_block (bitsToInts regs) (bitsToInts block)).

Definition sha_splitandpad (msg : Blist) : Blist :=
  bytesToBits (sha_padding_lemmas.pad (bitsToBytes msg)).

(* artifact of app_fpad definition *)
Definition fpad_inner (msg : list Z) : list Z :=
  (let n := BlockSize + Zlength msg in
  [128%Z]
    ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
    ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)]))%list.

Lemma fpad_inner_length l (L:length l = p): (length (fpad_inner (bitsToBytes l)) * 8)%nat = p.
Proof.
  unfold fpad_inner. repeat rewrite app_length.
  rewrite length_list_repeat, length_intlist_to_Zlist.
  rewrite (mult_comm 4), plus_comm, Zlength_correct.
  rewrite bitsToBytes_len_gen with (n:=32%nat).
    reflexivity.
    apply L.
Qed.

Definition fpad (msg : Blist) : Blist :=
  bytesToBits (fpad_inner (bitsToBytes msg)).

Lemma fpad_length msg (M:length msg = c): length (fpad msg) = p.
unfold fpad. rewrite bytesToBits_len. apply fpad_inner_length.
apply M. (*we're exploiting the fact that c=p here*)
Qed.

(* --------------- *)
Lemma xor_equiv_byte: forall xpad XPAD k K, isbyteZ XPAD ->
                          bytes_bits_lists xpad (HMAC_SHA256.sixtyfour XPAD) ->
                          ((length K) * 8)%nat = (c + p)%nat ->
                          bytes_bits_lists k (map Byte.unsigned K) ->
bytes_bits_lists (BLxor k xpad) (HMAC_SHA256.mkArgZ K (Byte.repr XPAD)).
Proof. intros.  apply inner_general_mapByte; try assumption.
       rewrite <- HMAC_SHA256.SF_ByteRepr; trivial.
Qed.

Lemma fold_left_iv_length: forall k (HK: forall iv x, length iv = k -> length (sha_h iv x) = k) l iv x ,
  length iv = k ->
  length (fold_left sha_h l (sha_h iv x)) = k.
Proof. intros k HK l.
  induction l. simpl. apply HK.
  simpl. intros.  rewrite IHl. trivial. apply HK. trivial.
Qed.

(* modified version of sha_padding_lemmas.pad *)
Definition pad_inc (msg : list Z) : list Z :=
  let n := BlockSize + Zlength msg in
  msg ++ [128%Z]
      ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
      ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)]).

Definition sha_splitandpad_inc (msg : Blist) : Blist :=
  bytesToBits (pad_inc (bitsToBytes msg)).

Lemma sha_splitandpad_inc_nil: length (sha_splitandpad_inc nil) = 512%nat.
Proof. reflexivity. Qed.

Lemma isbyteZ_pad_inc l (B:Forall isbyteZ l): Forall isbyteZ (pad_inc l).
Proof. unfold pad_inc.
  apply Forall_app. split. trivial.
  apply Forall_app. split. constructor. split; omega. trivial.
  apply Forall_app. split. apply Forall_list_repeat. split; omega.
  apply isbyte_intlist_to_Zlist.
Qed.

Lemma pad_inc_length: forall l, exists k, (0 < k /\ length (pad_inc l) = k*64)%nat.
Proof. unfold pad_inc.
  induction l.
  simpl. exists (1%nat). omega.
  destruct IHl as [k [K HK]]. repeat rewrite app_length in *. rewrite length_list_repeat in *.
  rewrite length_intlist_to_Zlist in *.
  remember (BinInt.Z.to_nat
        (BinInt.Z.modulo
           (BinInt.Z.opp
              (BinInt.Z.add (BinInt.Z.add BlockSize (Zcomplements.Zlength l))
                 9)) 64)).
  remember (BinInt.Z.to_nat
      (BinInt.Z.modulo
         (BinInt.Z.opp
            (BinInt.Z.add
               (BinInt.Z.add BlockSize (Zcomplements.Zlength (a :: l))) 9))
         64)).
  simpl. simpl in HK.
  assert ((BinInt.Z.add
                   (BinInt.Z.add BlockSize (Zcomplements.Zlength (a :: l))) 9) =
          BinInt.Z.add 1 (BinInt.Z.add
                   (BinInt.Z.add BlockSize (Zcomplements.Zlength l)) 9)).
        rewrite BinInt.Z.add_assoc. f_equal.
          rewrite BinInt.Z.add_assoc. rewrite (BinInt.Z.add_comm 1). rewrite <- (BinInt.Z.add_assoc _ 1).
          f_equal.
          repeat rewrite Zcomplements.Zlength_correct.
          apply (Znat.Nat2Z.inj_add 1 (length l)).
   rewrite H in Heqn0; clear H.
   remember (BinInt.Z.add (BinInt.Z.add BlockSize (Zcomplements.Zlength l)) 9). clear Heqz.
   subst n n0. rewrite Z.opp_add_distr. rewrite <- (Z.add_comm (-z)). remember (-z) as zz. clear Heqzz.
   simpl.
   destruct (zeq (zz mod 64) 0).
     rewrite e in HK.
     assert ((zz+-1) mod 64 = 63). clear - e.  apply Zmod_divides in e. 2:omega.
        destruct e. subst. rewrite Zplus_mod. rewrite Z.mul_comm. rewrite Z_mod_mult. simpl.
        reflexivity. (* rewrite Zmod_mod. apply Zmod_unique with (a:=(-1)). omega. omega.*)
     rewrite H. clear H e. simpl in *. exists (S k). omega.
   assert ((zz + -1) mod 64 = (zz mod 64) - 1 /\ 0 <= (zz mod 64) - 1).
     clear -n. rewrite Zplus_mod. assert (0 <= zz mod 64 < 64). apply Z.mod_pos_bound. omega.
     split. 2: omega.
     symmetry. eapply Z.mod_unique. left. omega.
     assert (63 = -1 mod 64). eapply Z.mod_unique. left; omega. instantiate (1:=-1). omega.
     rewrite <- H0. instantiate (1:=1). omega.
   destruct H. rewrite H. clear H.
   assert (Z.to_nat (zz mod 64 - 1) = minus (Z.to_nat (zz mod 64)) 1).
     clear - n H0. remember (zz mod 64).  clear Heqz. rewrite Z2Nat.inj_sub. reflexivity. omega.
   rewrite H; clear H. rewrite <- NPeano.Nat.add_sub_swap. rewrite minus_Sn_m. simpl. exists k. omega.
   omega. apply (Z2Nat.inj_le 1). omega. omega. omega.
Qed.

Lemma sha_splitandpad_inc_length: forall m, exists k,
      (0<k /\ length (sha_splitandpad_inc m) = k * 512)%nat.
Proof. intros. unfold sha_splitandpad_inc.
  destruct (pad_inc_length (bitsToBytes m)) as [k [K HK]].
  rewrite bytesToBits_len, HK. exists k. split. trivial. omega.
Qed.

Lemma sha_splitandpad_inc_InBlocks m : InBlocks 512 (sha_splitandpad_inc m).
Proof. intros. apply InBlocks_len.
  destruct (sha_splitandpad_inc_length m) as [k [K HK]].
  rewrite HK. exists k. trivial.
Qed.

Lemma sha_iv_length: length sha_iv = 256%nat.
Proof. reflexivity. Qed.

(*now in HMAC_common_defs
Lemma hash_blocks_bits_len: forall h
          (HH: forall x y, length x = c -> length y = b -> length (h x y)  = c)
          r l, length r = c ->
      InBlocks b l ->
      length (hash_blocks_bits h r l) = c.
Proof. intros h HH r l.
  apply hash_blocks_bits_ind.
  intros. trivial.
  intros. destruct _x. contradiction. subst msg; clear y.
  inv H1.
  apply H; clear H. rewrite HH. trivial. trivial.
    rewrite H3, firstn_exact. apply H2. apply H2.
    rewrite H3, skipn_exact. assumption. apply H2.
Qed.*)

Lemma B: (0<b)%nat. unfold b; simpl. omega. Qed.

Lemma hash_blocks_bits_len': forall r l, length r = 256%nat ->
      InBlocks 512 l ->
      length (hash_blocks_bits _ B sha_h r l) = 256%nat.
Proof. intros r l.
  apply hash_blocks_bits_ind.
  intros. trivial.
  intros. destruct _x. contradiction. subst msg; clear y.
  inv H1.
  apply H; clear H. unfold sha_h, intsToBits.
  rewrite bytesToBits_len, length_intlist_to_Zlist.
  rewrite length_hash_block. omega.
  unfold bitsToInts. erewrite length_Zlist_to_intlist. reflexivity.
    rewrite bitsToBytes_len_gen with (n:=32%nat). reflexivity. apply H0.
  unfold bitsToInts. erewrite length_Zlist_to_intlist. reflexivity.
    erewrite bitsToBytes_len_gen with (n:=64%nat). reflexivity.
    rewrite H3, firstn_exact. apply H2. apply H2.
    rewrite H3, skipn_exact. assumption. apply H2.
Qed.

Lemma sha_h_length iv blk: length iv = c -> length blk = b ->
      length (sha_h iv blk) = c.
Proof. intros.
 unfold sha_h, intsToBits.
  rewrite bytesToBits_len, length_intlist_to_Zlist.
  rewrite common_lemmas.length_hash_block. reflexivity.
  unfold bitsToInts. erewrite pure_lemmas.length_Zlist_to_intlist. reflexivity.
  erewrite bitsToBytes_len_gen. reflexivity.
  rewrite H; reflexivity.
  unfold bitsToInts. erewrite pure_lemmas.length_Zlist_to_intlist. reflexivity.
  erewrite bitsToBytes_len_gen. reflexivity.
  rewrite H0; reflexivity.
Qed.

(*******Injectivity of pad_inc*************************)

Lemma pad_injective_aux (l1 l2: list Z) k
     (K : k * Int.modulus + (BlockSize + Zlength l1) * 8 =
          (BlockSize + Zlength l2) * 8)
     (N : k <> 0):
     - (BlockSize + Zlength l2 + 9) mod 64 = - (BlockSize + Zlength l1 + 9) mod 64.
Proof. repeat rewrite <- Z.add_assoc. unfold BlockSize.
         repeat rewrite Z.opp_add_distr.
         rewrite (Zplus_mod (-(64))).
         assert (- (64) mod 64 = 0). reflexivity. rewrite H.
         rewrite (Zplus_mod (-(64))). rewrite H. simpl.
         repeat rewrite Zmod_mod.
         f_equal. f_equal.
         rewrite Zplus_mod. rewrite (Zplus_mod (- Zlength l1)).
         assert (Z12: - Zlength l2 mod 64 = - Zlength l1 mod 64).
         { clear H. repeat rewrite Z.mul_add_distr_r in K.
           assert (k * Int.modulus + Zlength l1 * 8 = Zlength l2 * 8). omega.
           clear K.
           assert (KK: k * (Int.modulus/8) + Zlength l1 = Zlength l2).
              rewrite <- (Zdiv_unique (k * Int.modulus + Zlength l1 * 8) 8 (Zlength l2) 0).
              2: rewrite Z.add_0_r; trivial. 2: omega.
              clear H. remember (Zlength l1) as z; clear Heqz.
              remember ((Int.modulus / 8)).
              assert (Int.modulus = z0 * 8). subst.
                rewrite <- max_unsigned_modulus, int_max_unsigned_eq. trivial.
              rewrite H; clear H Heqz0. rewrite Z.mul_assoc.
              rewrite (Z_div_plus_full_l (k*z0) 8 (z*8)). 2: omega.
              rewrite Z_div_mult_full. trivial. omega.
           rewrite <- KK; clear H KK.
           rewrite Z.opp_add_distr.
           rewrite Zplus_mod.
           assert (KM: - (k * (Int.modulus / 8)) mod 64 = 0).
             apply Zmod_unique with (a:=-k * 8388608). 2: omega. rewrite Zplus_0_r.
             rewrite <- max_unsigned_modulus, int_max_unsigned_eq. simpl.
             rewrite Zopp_mult_distr_l, <- Z.mul_assoc. reflexivity.
           rewrite KM. simpl. apply Z.mod_mod. omega.
         }
         rewrite Z12; trivial.
Qed.

Lemma pad_injective_Case5 l1 l2
  (H0 : (l1 ++ 128 :: nil) ++
        list_repeat (Z.to_nat (- (BlockSize + Zlength l1 + 9) mod 64)) 0 =
        (l2 ++ 128 :: nil) ++
        list_repeat (Z.to_nat (- (BlockSize + Zlength l2 + 9) mod 64)) 0)
  (H : (BlockSize + Zlength l1) * 8 =
       ((BlockSize + Zlength l2) * 8) mod Int.modulus)
  (Nonneg1 : 0 <= (BlockSize + Zlength l1) * 8)
  (l : (BlockSize + Zlength l1) * 8 < Int.modulus):
  length l1 = length l2.
Proof. symmetry in H.
       destruct (mod_exists _ _ _ H) as [k K].
       specialize Int.modulus_pos; intros; omega.
       destruct (zeq k 0).
         subst. clear - K.
         assert (Zlength l1 = Zlength l2). omega.
         repeat rewrite Zlength_correct in H.
         rewrite <- (Nat2Z.id (length l1)).
         rewrite <- (Nat2Z.id (length l2)).
         rewrite H. reflexivity.
       clear H.
       assert (length ((l1 ++ 128 :: nil) ++
                list_repeat (Z.to_nat (- (BlockSize + Zlength l1 + 9) mod 64)) 0)
             = length ((l2 ++ 128 :: nil) ++
                list_repeat (Z.to_nat (- (BlockSize + Zlength l2 + 9) mod 64)) 0)).
       rewrite H0; trivial.
       clear H0. repeat rewrite app_length in H.
       repeat rewrite length_list_repeat in H.
       clear - K n H.
       rewrite (pad_injective_aux l1 l2 k K n) in H. omega.
Qed.

Lemma pad_inc_injective: forall l1 l2, pad_inc l1 = pad_inc l2 -> l1=l2.
Proof. intros.
remember (beq_nat (length l1) (length l2)) as d.
destruct d.
{ apply beq_nat_eq in Heqd.
  unfold pad_inc in H. repeat rewrite Zlength_correct in H.
  rewrite <- Heqd in H.
  eapply app_inv_tail. apply H. }
{ symmetry in Heqd; apply beq_nat_false in Heqd.
  unfold pad_inc in H.
  repeat rewrite app_assoc in H.
  destruct (app_inv_length2 _ _ _ _ H); clear H. reflexivity.
  apply intlist_to_Zlist_inj in H1.
  apply cons_inv in H1. destruct H1 as [_ Y].
  apply cons_inv in Y. destruct Y as [Y _].
  assert (Int.unsigned (Int.repr ((BlockSize + Zlength l1) * 8)) = Int.unsigned (Int.repr ((BlockSize + Zlength l2) * 8))).
    rewrite Y; trivial.
  elim Heqd; clear Heqd Y.
  repeat rewrite Int.unsigned_repr_eq in H.
  assert (Nonneg1: 0 <= (BlockSize + Zlength l1) * 8).
    specialize (Zlength_nonneg l1). intros; unfold BlockSize; omega.
  assert (Nonneg2: 0 <= (BlockSize + Zlength l2) * 8).
    specialize (Zlength_nonneg l2). intros; unfold BlockSize; omega.
  remember (zlt ((BlockSize + Zlength l1) * 8) Int.modulus).
  destruct s; clear Heqs.
  {  rewrite Zmod_small in H. 2: split; assumption.
     remember (zlt ((BlockSize + Zlength l2) * 8) Int.modulus).
     destruct s; clear Heqs.
     { (*Case 3*)
       rewrite Zmod_small in H. 2: split; assumption.
       clear - H.
       assert (Zlength l1 = Zlength l2). omega.
       repeat rewrite Zlength_correct in H0.
       rewrite <- (Nat2Z.id (length l1)).
       rewrite <- (Nat2Z.id (length l2)).
       rewrite H0. reflexivity. }
     { (*Case 5*) clear g Nonneg2.
       apply pad_injective_Case5; assumption. } }
  { clear g Nonneg1.
    remember (zlt ((BlockSize + Zlength l2) * 8) Int.modulus).
    destruct s; clear Heqs.
    { (*Case 5, symmetric version*)
       rewrite (Zmod_small ((BlockSize + Zlength l2) * 8)) in H. 2: split; assumption.
       symmetry. symmetry in H. symmetry in H0.
       apply pad_injective_Case5; assumption. }
    { clear Nonneg2 g.
      remember ((BlockSize + Zlength l1) * 8) as z1.
      remember ((BlockSize + Zlength l2) * 8) as z2.

      rewrite Zmod_eq in H. 2: apply Int.modulus_pos. remember (z1 / Int.modulus) as k1; clear Heqk1.
      rewrite Zmod_eq in H. 2: apply Int.modulus_pos. remember (z2 / Int.modulus) as k2; clear Heqk2.
      destruct (zeq k1 k2).
      { subst. clear -H.
        assert (Zlength l1 = Zlength l2). omega.
        repeat rewrite Zlength_correct in H0.
        rewrite <- (Nat2Z.id (length l1)).
        rewrite <- (Nat2Z.id (length l2)).
        rewrite H0. reflexivity. }
      { assert (length ((l1 ++ 128 :: nil) ++
                 list_repeat (Z.to_nat (- (BlockSize + Zlength l1 + 9) mod 64)) 0)
              = length ((l2 ++ 128 :: nil) ++
                 list_repeat (Z.to_nat (- (BlockSize + Zlength l2 + 9) mod 64)) 0)).
          rewrite H0; trivial.
        clear H0. repeat rewrite app_length in H1.
        repeat rewrite length_list_repeat in H1.
        rewrite (pad_injective_aux l2 l1 (k1-k2)) in H1.
          omega.
          rewrite Z.mul_sub_distr_r; omega.
          omega. } } } }
Qed.
(********************************************************************)

Lemma block_8 A (l:list A): length l = b -> InBlocks 8 l.
Proof.
  intros len. apply InBlocks_len. exists 64%nat. apply len.
Qed.

Lemma sha_splitandpad_app : forall (l m : Blist),
                         length l = b ->
                         sha_splitandpad (l ++ m) = l ++ sha_splitandpad_inc m.
Proof.
  intros l m len.
  unfold sha_splitandpad. unfold sha_splitandpad_inc.
  unfold pad. unfold pad_inc.

  rewrite -> bitsToBytes_app.
  rewrite -> Zlength_app.
  repeat rewrite -> bytesToBits_app.
  rewrite -> bits_bytes_bits_id.
  rewrite <- app_assoc.
  repeat f_equal.
  unfold b, c, p in *. simpl in *.

  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply bitsToBytes_len. apply len.
  * apply block_8. apply len.
  * apply block_8. apply len.
Qed.

Lemma pad_isbyteZ: forall l, Forall isbyteZ l -> Forall isbyteZ (pad l).
Proof. intros. unfold pad.
  apply Forall_app.
  split; trivial.
  apply Forall_app.
  split. constructor. unfold isbyteZ; omega. constructor.
  apply Forall_app.
  split. apply Forall_list_repeat. unfold isbyteZ; omega.
  apply isbyte_intlist_to_Zlist.
Qed.

Lemma isbyte_hmaccore ipad opad m k:
   Forall isbyteZ (HMAC_SHA256.HmacCore (Byte.repr ipad) (Byte.repr opad) m k).
Proof. apply SHA256.Hash_isbyteZ. Qed.

(*
Module SHAHF <: Hashfunction.
(* TODO use neater definition with conversion functions *)
(* TODO split out of HMAC_spec_pad *)

Definition c := (32 * 8)%nat.
Definition p := (32 * 8)%nat.
Definition b := (c + p)%nat.
Definition BlockSize := 64.

Definition sha_iv : Blist :=
  intsToBits SHA256.init_registers.

Definition sha_h (regs : Blist) (block : Blist) : Blist :=
  intsToBits (SHA256.hash_block (bitsToInts regs) (bitsToInts block)).

Definition sha_splitandpad (msg : Blist) : Blist :=
  bytesToBits (sha_padding_lemmas.pad (bitsToBytes msg)).

(* artifact of app_fpad definition *)
Definition fpad_inner (msg : list Z) : list Z :=
  (let n := BlockSize + Zlength msg in
  [128%Z]
    ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
    ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)]))%list.

Definition fpad (msg : Blist) : Blist :=
  bytesToBits (fpad_inner (bitsToBytes msg)).

Lemma fold_left_iv_length: forall k (HK: forall iv x, length iv = k -> length (sha_h iv x) = k) l iv x ,
  length iv = k ->
  length (fold_left sha_h l (sha_h iv x)) = k.
Proof. intros k HK l.
  induction l. simpl. apply HK.
  simpl. intros.  rewrite IHl. trivial. apply HK. trivial.
Qed.

(* modified version of sha_padding_lemmas.pad *)
Definition pad_inc (msg : list Z) : list Z :=
  let n := BlockSize + Zlength msg in
  msg ++ [128%Z]
      ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0
      ++ intlist_to_Zlist ([Int.repr (n * 8 / Int.modulus); Int.repr (n * 8)]).

Definition sha_splitandpad_inc (msg : Blist) : Blist :=
  bytesToBits (pad_inc (bitsToBytes msg)).

Lemma sha_splitandpad_inc_nil: length (sha_splitandpad_inc nil) = 512%nat.
Proof. reflexivity. Qed.

Lemma isbyteZ_pad_inc l (B:Forall isbyteZ l): Forall isbyteZ (pad_inc l).
Proof. unfold pad_inc.
  apply Forall_app. split. trivial.
  apply Forall_app. split. constructor. split; omega. trivial.
  apply Forall_app. split. apply Forall_list_repeat. split; omega.
  apply isbyte_intlist_to_Zlist.
Qed.

Lemma pad_inc_length: forall l, exists k, (0 < k /\ length (pad_inc l) = k*64)%nat.
Proof. unfold pad_inc.
  induction l.
  simpl. exists (1%nat). omega.
  destruct IHl as [k [K HK]]. repeat rewrite app_length in *. rewrite length_list_repeat in *.
  rewrite pure_lemmas.length_intlist_to_Zlist in *.
  remember (BinInt.Z.to_nat
        (BinInt.Z.modulo
           (BinInt.Z.opp
              (BinInt.Z.add (BinInt.Z.add BlockSize (Zcomplements.Zlength l))
                 9)) 64)).
  remember (BinInt.Z.to_nat
      (BinInt.Z.modulo
         (BinInt.Z.opp
            (BinInt.Z.add
               (BinInt.Z.add BlockSize (Zcomplements.Zlength (a :: l))) 9))
         64)).
  simpl. simpl in HK.
  assert ((BinInt.Z.add
                   (BinInt.Z.add BlockSize (Zcomplements.Zlength (a :: l))) 9) =
          BinInt.Z.add 1 (BinInt.Z.add
                   (BinInt.Z.add BlockSize (Zcomplements.Zlength l)) 9)).
        rewrite BinInt.Z.add_assoc. f_equal.
          rewrite BinInt.Z.add_assoc. rewrite (BinInt.Z.add_comm 1). rewrite <- (BinInt.Z.add_assoc _ 1).
          f_equal.
          repeat rewrite Zcomplements.Zlength_correct.
          apply (Znat.Nat2Z.inj_add 1 (length l)).
   rewrite H in Heqn0; clear H.
   remember (BinInt.Z.add (BinInt.Z.add BlockSize (Zcomplements.Zlength l)) 9). clear Heqz.
   subst n n0. rewrite Z.opp_add_distr. rewrite <- (Z.add_comm (-z)). remember (-z) as zz. clear Heqzz.
   simpl.
   destruct (zeq (zz mod 64) 0).
     rewrite e in HK.
     assert ((zz+-1) mod 64 = 63). clear - e.  apply Zmod_divides in e. 2:omega.
        destruct e. subst. rewrite Zplus_mod. rewrite Z.mul_comm. rewrite Z_mod_mult. simpl.
        rewrite Zmod_mod. apply Zmod_unique with (a:=(-1)). omega. omega.
     rewrite H. clear H e. simpl in *. exists (S k). omega.
   assert ((zz + -1) mod 64 = (zz mod 64) - 1 /\ 0 <= (zz mod 64) - 1).
     clear -n. rewrite Zplus_mod. assert (0 <= zz mod 64 < 64). apply Z.mod_pos_bound. omega.
     split. 2: omega.
     symmetry. eapply Z.mod_unique. left. omega.
     assert (63 = -1 mod 64). eapply Z.mod_unique. left; omega. instantiate (1:=-1). omega.
     rewrite <- H0. instantiate (1:=1). omega.
   destruct H. rewrite H. clear H.
   assert (Z.to_nat (zz mod 64 - 1) = minus (Z.to_nat (zz mod 64)) 1).
     clear - n H0. remember (zz mod 64).  clear Heqz. rewrite Z2Nat.inj_sub. reflexivity. omega.
   rewrite H; clear H. rewrite <- NPeano.Nat.add_sub_swap. rewrite minus_Sn_m. simpl. exists k. omega.
   omega. apply (Z2Nat.inj_le 1). omega. omega. omega.
Qed.

Lemma sha_splitandpad_inc_length: forall m, exists k,
      (0<k /\ length (sha_splitandpad_inc m) = k * 512)%nat.
Proof. intros. unfold sha_splitandpad_inc.
  destruct (pad_inc_length (bitsToBytes m)) as [k [K HK]].
  rewrite bytesToBits_len, HK. exists k. split. trivial. omega.
Qed.

Lemma sha_splitandpad_inc_InBlocks m : InBlocks 512 (sha_splitandpad_inc m).
Proof. intros. apply InBlocks_len.
  destruct (sha_splitandpad_inc_length m) as [k [K HK]].
  rewrite HK. exists k. trivial.
Qed.

Lemma sha_iv_length: length sha_iv = 256%nat.
Proof. reflexivity. Qed.

Lemma hash_blocks_bits_len: forall r l, length r = 256%nat ->
      InBlocks 512 l ->
      length (hash_blocks_bits sha_h r l) = 256%nat.
Proof. intros r l.
  apply hash_blocks_bits_ind.
  intros. trivial.
  intros. destruct _x. contradiction. subst msg; clear y.
  inv H1.
  apply H; clear H. unfold sha_h, intsToBits.
 rewrite bytesToBits_len, length_intlist_to_Zlist.
  rewrite length_hash_block. omega.
  unfold bitsToInts. erewrite length_Zlist_to_intlist. reflexivity.
    rewrite bitsToBytes_len_gen with (n:=32%nat). reflexivity. apply H0.
  unfold bitsToInts. erewrite length_Zlist_to_intlist. reflexivity.
    erewrite bitsToBytes_len_gen with (n:=64%nat). reflexivity.
    rewrite H3, firstn_exact. apply H2. apply H2.
    rewrite H3, skipn_exact. assumption. apply H2.
Qed.

Lemma sha_h_length iv blk: length iv = c -> length blk = b ->
      length (sha_h iv blk) = c.
Proof. intros.
 unfold sha_h, intsToBits.
  rewrite bytesToBits_len, pure_lemmas.length_intlist_to_Zlist.
  rewrite common_lemmas.length_hash_block. reflexivity.
  unfold bitsToInts. erewrite pure_lemmas.length_Zlist_to_intlist. reflexivity.
  erewrite bitsToBytes_len_gen. reflexivity.
  rewrite H; reflexivity.
  unfold bitsToInts. erewrite pure_lemmas.length_Zlist_to_intlist. reflexivity.
  erewrite bitsToBytes_len_gen. reflexivity.
  rewrite H0; reflexivity.
Qed.

(*******Injectivity of pad_inc*************************)

Lemma pad_injective_aux (l1 l2: list Z) k
     (K : k * Int.modulus + (BlockSize + Zlength l1) * 8 =
          (BlockSize + Zlength l2) * 8)
     (N : k <> 0):
     - (BlockSize + Zlength l2 + 9) mod 64 = - (BlockSize + Zlength l1 + 9) mod 64.
Proof. repeat rewrite <- Z.add_assoc. unfold BlockSize.
         repeat rewrite Z.opp_add_distr.
         rewrite (Zplus_mod (-(64))).
         assert (- (64) mod 64 = 0). reflexivity. rewrite H.
         rewrite (Zplus_mod (-(64))). rewrite H. simpl.
         repeat rewrite Zmod_mod.
         rewrite Zplus_mod. rewrite (Zplus_mod (- Zlength l1)).
         assert (Z12: - Zlength l2 mod 64 = - Zlength l1 mod 64).
         { clear H. repeat rewrite Z.mul_add_distr_r in K.
           assert (k * Int.modulus + Zlength l1 * 8 = Zlength l2 * 8). omega.
           clear K.
           assert (KK: k * (Int.modulus/8) + Zlength l1 = Zlength l2).
              rewrite <- (Zdiv_unique (k * Int.modulus + Zlength l1 * 8) 8 (Zlength l2) 0).
              2: rewrite Z.add_0_r; trivial. 2: omega.
              clear H. remember (Zlength l1) as z; clear Heqz.
              remember ((Int.modulus / 8)).
              assert (Int.modulus = z0 * 8). subst.
                rewrite <- max_unsigned_modulus, int_max_unsigned_eq. trivial.
              rewrite H; clear H Heqz0. rewrite Z.mul_assoc.
              rewrite (Z_div_plus_full_l (k*z0) 8 (z*8)). 2: omega.
              rewrite Z_div_mult_full. trivial. omega.
           rewrite <- KK; clear H KK.
           rewrite Z.opp_add_distr.
           rewrite Zplus_mod.
           assert (KM: - (k * (Int.modulus / 8)) mod 64 = 0).
             apply Zmod_unique with (a:=-k * 8388608). 2: omega. rewrite Zplus_0_r.
             rewrite <- max_unsigned_modulus, int_max_unsigned_eq. simpl.
             rewrite Zopp_mult_distr_l, <- Z.mul_assoc. reflexivity.
           rewrite KM. simpl. apply Z.mod_mod. omega.
         }
         rewrite Z12; trivial.
Qed.

Lemma pad_injective_Case5 l1 l2
  (H0 : (l1 ++ 128 :: nil) ++
        list_repeat (Z.to_nat (- (BlockSize + Zlength l1 + 9) mod 64)) 0 =
        (l2 ++ 128 :: nil) ++
        list_repeat (Z.to_nat (- (BlockSize + Zlength l2 + 9) mod 64)) 0)
  (H : (BlockSize + Zlength l1) * 8 =
       ((BlockSize + Zlength l2) * 8) mod Int.modulus)
  (Nonneg1 : 0 <= (BlockSize + Zlength l1) * 8)
  (l : (BlockSize + Zlength l1) * 8 < Int.modulus):
  length l1 = length l2.
Proof. symmetry in H.
       destruct (mod_exists _ _ _ H) as [k K].
       specialize Int.modulus_pos; intros; omega.
       destruct (zeq k 0).
         subst. clear - K.
         assert (Zlength l1 = Zlength l2). omega.
         repeat rewrite Zlength_correct in H.
         rewrite <- (Nat2Z.id (length l1)).
         rewrite <- (Nat2Z.id (length l2)).
         rewrite H. reflexivity.
       clear H.
       assert (length ((l1 ++ 128 :: nil) ++
                list_repeat (Z.to_nat (- (BlockSize + Zlength l1 + 9) mod 64)) 0)
             = length ((l2 ++ 128 :: nil) ++
                list_repeat (Z.to_nat (- (BlockSize + Zlength l2 + 9) mod 64)) 0)).
       rewrite H0; trivial.
       clear H0. repeat rewrite app_length in H.
       repeat rewrite length_list_repeat in H.
       clear - K n H.
       rewrite (pad_injective_aux l1 l2 k K n) in H. omega.
Qed.

Lemma pad_inc_injective: forall l1 l2, pad_inc l1 = pad_inc l2 -> l1=l2.
Proof. intros.
remember (beq_nat (length l1) (length l2)) as d.
destruct d.
{ apply beq_nat_eq in Heqd.
  unfold pad_inc in H. repeat rewrite Zlength_correct in H.
  rewrite <- Heqd in H.
  eapply app_inv_tail. apply H. }
{ symmetry in Heqd; apply beq_nat_false in Heqd.
  unfold pad_inc in H.
  repeat rewrite app_assoc in H.
  destruct (app_inv_length2 _ _ _ _ H); clear H. reflexivity.
  apply pure_lemmas.intlist_to_Zlist_inj in H1.
  apply cons_inv in H1. destruct H1 as [_ Y].
  apply cons_inv in Y. destruct Y as [Y _].
  assert (Int.unsigned (Int.repr ((BlockSize + Zlength l1) * 8)) = Int.unsigned (Int.repr ((BlockSize + Zlength l2) * 8))).
    rewrite Y; trivial.
  elim Heqd; clear Heqd Y.
  repeat rewrite Int.unsigned_repr_eq in H.
  assert (Nonneg1: 0 <= (BlockSize + Zlength l1) * 8).
    specialize (Zlength_nonneg l1). intros; unfold BlockSize; omega.
  assert (Nonneg2: 0 <= (BlockSize + Zlength l2) * 8).
    specialize (Zlength_nonneg l2). intros; unfold BlockSize; omega.
  remember (zlt ((BlockSize + Zlength l1) * 8) Int.modulus).
  destruct s; clear Heqs.
  {  rewrite Zmod_small in H. 2: split; assumption.
     remember (zlt ((BlockSize + Zlength l2) * 8) Int.modulus).
     destruct s; clear Heqs.
     { (*Case 3*)
       rewrite Zmod_small in H. 2: split; assumption.
       clear - H.
       assert (Zlength l1 = Zlength l2). omega.
       repeat rewrite Zlength_correct in H0.
       rewrite <- (Nat2Z.id (length l1)).
       rewrite <- (Nat2Z.id (length l2)).
       rewrite H0. reflexivity. }
     { (*Case 5*) clear g Nonneg2.
       apply pad_injective_Case5; assumption. } }
  { clear g Nonneg1.
    remember (zlt ((BlockSize + Zlength l2) * 8) Int.modulus).
    destruct s; clear Heqs.
    { (*Case 5, symmetric version*)
       rewrite (Zmod_small ((BlockSize + Zlength l2) * 8)) in H. 2: split; assumption.
       symmetry. symmetry in H. symmetry in H0.
       apply pad_injective_Case5; assumption. }
    { clear Nonneg2 g.
      remember ((BlockSize + Zlength l1) * 8) as z1.
      remember ((BlockSize + Zlength l2) * 8) as z2.

      rewrite Zmod_eq in H. 2: apply Int.modulus_pos. remember (z1 / Int.modulus) as k1; clear Heqk1.
      rewrite Zmod_eq in H. 2: apply Int.modulus_pos. remember (z2 / Int.modulus) as k2; clear Heqk2.
      destruct (zeq k1 k2).
      { subst. clear -H.
        assert (Zlength l1 = Zlength l2). omega.
        repeat rewrite Zlength_correct in H0.
        rewrite <- (Nat2Z.id (length l1)).
        rewrite <- (Nat2Z.id (length l2)).
        rewrite H0. reflexivity. }
      { assert (length ((l1 ++ 128 :: nil) ++
                 list_repeat (Z.to_nat (- (BlockSize + Zlength l1 + 9) mod 64)) 0)
              = length ((l2 ++ 128 :: nil) ++
                 list_repeat (Z.to_nat (- (BlockSize + Zlength l2 + 9) mod 64)) 0)).
          rewrite H0; trivial.
        clear H0. repeat rewrite app_length in H1.
        repeat rewrite length_list_repeat in H1.
        rewrite (pad_injective_aux l2 l1 (k1-k2)) in H1.
          omega.
          rewrite Z.mul_sub_distr_r; omega.
          omega. } } } }
Qed.
(********************************************************************)

Lemma block_8 A (l:list A): length l = b -> InBlocks 8 l.
Proof.
  intros len. apply InBlocks_len. exists 64%nat. apply len.
Qed.

Lemma xor_equiv_byte: forall xpad XPAD k K, isbyteZ XPAD ->
                          bytes_bits_lists xpad (HP.HMAC_SHA256.sixtyfour XPAD) ->
                          bytes_bits_lists k (map Byte.unsigned K) ->
bytes_bits_lists (BLxor k xpad) (HP.HMAC_SHA256.mkArgZ K (Byte.repr XPAD)).
Proof. intros.  apply inner_general_mapByte; try assumption.
       rewrite <- SF_ByteRepr; trivial.
Qed.

  Definition hf_c := (32 * 8)%nat.
  Definition hf_p := (32 * 8)%nat.
  Definition hf_b := (hf_c + hf_p)%nat.
  Definition hf_iv := intsToBits SHA256.init_registers.
  Definition hf_h := sha_h.
(*  Definition hf_pad_inc := pad_inc.
  Definition hf_splitandpad_inc (msg : Blist) : Blist := bytesToBits (hf_pad_inc (bitsToBytes msg)).
  Definition hf_pad_inc_injective := pad_inc_injective.*)

  Definition hf_iv_length := sha_iv_length.
  Definition hf_h_length := sha_h_length.
  Definition hf_block_8 := block_8.
End SHAHF.
*)


Require Import CT.Category.
Require Import CT.Instance.Category.FunctorCategory.
Require Import CT.Instance.Category.ProductCategory.

Set Universe Polymorphism.

(** The opposite category for a category. *)
Program Definition Op (C : Category) : Category :=
  {| ob := @ob C;
     mor := fun a b => mor b a;
     comp := fun _ _ _ f g => comp g f;
     id := fun a => @id C a;
     assoc := fun _ _ _ _ _ _ _ => @assoc_sym _ _ _ _ _ _ _ _;
     assoc_sym := fun _ _ _ _ _ _ _ => @assoc _ _ _ _ _ _ _ _;
     id_left := fun _ _ => @id_right _ _ _;
     id_right := fun _ _ => @id_left _ _ _
  |}.

Notation "A '^op'" := (Op A) (at level 10).

Theorem c_op_op_is_c :
  forall C, C^op^op = C.
Proof.
  trivial.
Qed.

Theorem op_preserves_functors :
  forall C D,
    (FunctorCategory C D)^op = FunctorCategory (C^op) (D^op).
Proof.
  admit.
Admitted.

Theorem op_preserves_products :
  forall C D,
    (ProductCategory C D)^op = ProductCategory (C^op) (D^op).
Proof.
  admit.
Admitted.