Axiom fun_ext : forall A:Type, forall B:A -> Type, forall f g:(forall a:A, B a), (f = g) = (forall a:A, f a = g a).
Axiom Arrow : Type.
Axiom source : Arrow.
Axiom target : Arrow.
Axiom ale : Arrow -> Arrow -> Prop.
Axiom ale_sym : forall x y:Arrow, (ale x y * ale y x)%type = (x = y).
Axiom ale_trans : forall x y z:Arrow, ale x y -> ale y z -> ale x z.
Axiom ale_total : forall x y:Arrow, (ale x y) + (ale y x)%type.
Axiom ale_top : forall x:Arrow, ale x target.
Axiom ale_bot : forall x:Arrow, ale source x.
Axiom ale_not : target <> source.

Definition ale_join : Arrow -> Arrow -> Arrow.
intros s t.
destruct (ale_total s t).
apply s.
apply t.
Defined.

Definition ale_meet : Arrow -> Arrow -> Arrow.
intros s t.
destruct (ale_total s t).
apply t.
apply s.
Defined.
Definition Span(X Y:Type) : Type := {E:Type & (E -> X) * (E -> Y)}%type.

Definition fun2span : forall X Y:Type, (X -> Y) -> (Span X Y).
intros.
exists X.
split.
intro x.
apply x.
apply X0.
Defined.

Axiom walking : (Arrow -> Type) = {X:Type & {Y:Type & Span X Y}}.

Lemma walking_cast : (Arrow -> Type) -> {X:Type & {Y:Type & Span X Y}}.
intros.
rewrite walking in X.
apply X.
Defined.

Lemma walking_cast_inv : {X:Type & {Y:Type & Span X Y}} -> (Arrow -> Type).
rewrite <- walking.
intro f.
apply f.
Defined.

Axiom walking_eval_source : forall F:Arrow -> Type, ((projT1 (walking_cast F)) = (F source)).
Axiom walking_eval_target : forall F:Arrow -> Type, ((projT1 (projT2 (walking_cast F))) = (F target)).

Theorem walking_cast_iso : forall F:Arrow -> Type, F = (walking_cast_inv (walking_cast F)).
cbv.
intro F.
destruct walking.
trivial.
Defined.

Theorem walking_cast_iso2 : forall F:{X : Type & {Y : Type & Span X Y}}, F = (walking_cast (walking_cast_inv F)).
cbv.
intro F.
rewrite walking.
trivial.
Defined.

Axiom fun_arrow : forall A:Type, forall B:A -> Type, (Arrow -> (forall a:A, B a)) = (forall a:A, Arrow -> B a).
Lemma fun_arrow_cast {A:Type}{B:A -> Type}(f:forall a:A, Arrow -> B a) : (Arrow -> (forall a:A, B a)).
rewrite fun_arrow.
apply f.
Defined.

Axiom fun_arrow_eval : forall A:Type, forall B:A -> Type, forall f:(forall a:A, Arrow -> B a), forall x:Arrow, (fun_arrow_cast f x) = (fun a:A => f a x).

Definition compose{A B C:Type}(f:B -> C)(g:A -> B) : A -> C := fun a:A => f (g a).
Definition monic{A B:Type}(f:A -> B) := forall C:Type, forall g g':C -> A, ((compose f g) = (compose f g')) -> (g = g').
Definition epic{A B:Type}(f:A -> B) := forall C:Type, forall g g':B -> C, ((compose g f) = (compose g' f)) -> (g = g').
Definition automorphicType : forall x y:Type, (x = y) -> (Arrow -> Type).
intros X Y H.
induction H.
apply (walking_cast_inv (existT _ _ (existT _ _ (fun2span _ _ (fun x:X => x))))).
Defined.

Theorem amTSource : forall x y:Type, forall p:x = y, (automorphicType x y p source) = x.
intros.
unfold automorphicType.
destruct p.
assert ((existT (fun X : Type => {Y : Type & Span X Y}) x
        (existT (Span x) x (fun2span x x (fun x0 : x => x0)))) = (walking_cast (automorphicType x x eq_refl ))).
unfold automorphicType.
rewrite walking_cast_iso2.
cbv.
Theorem amTTarget : forall x y:Type, forall p:x = y, (automorphicType x y p target) = y.
Theorem amTMonic : forall x y:Type, monic (automorphicType x y).

Axiom automorphic : forall X:Type, forall x y:X, (x = y) -> (Arrow -> X).
Axiom automorphicEval : (automorphic Type) = automorphicType.

Axiom amSource : forall X:Type, forall x y:X, forall p:x = y, (automorphic X x y p source) = x.
Axiom amTarget : forall X:Type, forall x y:X, forall p:x = y, (automorphic X x y p target) = y.
Axiom amMonic : forall X:Type, forall x y:X, monic (automorphic X x y).

Theorem QQQ :

Axiom autoevalaxiom : forall X:Type, (walking_cast (automorphic Type X X (eq_refl))) = (existT (fun X:Type => {Y:Type & X -> Y}) X (existT (fun Y:Type => X -> Y) X (fun x:X => x))).

Definition Cube : nat -> Type := (fix F m := match m with
                                             |0 => unit
                                             |1 => Arrow
                                             |S j => (Arrow * (F j))%type
                                             end).

Theorem QQQ : DescendingList (cons source (cons target nil)).
cbv.
split.
apply ale_bot.
trivial.
Defined.

Lemma doubleduh : forall (a b : Arrow), (ale a b) -> forall (l : list Arrow), DescendingList (a :: (b :: l))%list -> DescendingList l.
intros.
destruct H0.
apply H1.

Theorem duh : forall (l : list Arrow) (a : Arrow), DescendingList (a :: l) -> DescendingList l.
intro l.
destruct l.
trivial.
destruct l.
intros.
cbv.
trivial.
intros a1 H1.
split.

Theorem QQQQ : forall l:(list Arrow), (DescendingList l) -> DescendingList (cons source l).
intros.
destruct l.
trivial.
split.
apply ale_bot.
generalize H.
generalize l.
generalize a.
clear H.
clear l.
clear a.

Definition topCube : forall n:nat, Cube (S n) -> Cube n.
intros.
destruct n.
apply tt.
destruct X.
apply c.
Defined.

Definition idCube : forall n:nat, Cube n.
intros.
destruct n.
apply tt.
induction n.
cbv.
apply source.
apply (source, IHn).
Defined.

Lemma refl_depends : forall X:Type, forall x:X, {f:Arrow -> X & (f source) = x /\ (f target) = x}.
intros.
exists (automorphic X x x (eq_refl)).
split.
apply amSource.
apply amTarget.
Defined.

Record Category := mkCat
{
  Obj : Type;
  composeArrow : forall A B C:Obj, {f:Arrow -> Obj & f source = B /\ f target = C} -> {g:Arrow -> Obj & g source = A /\ g target = B} -> {h:Arrow -> Obj & h source = A /\ h target = C};
  law_compose_id_left : forall A B: Obj, forall F:{f:Arrow -> Obj & f source = A /\ f target = B}, (composeArrow _ _ _ F (refl_depends _ _)) = F;
  law_compose_id_right : forall A B: Obj, forall F:{f:Arrow -> Obj & f source = A /\ f target = B}, (composeArrow _ _ _ (refl_depends _ _) F) = F;
  law_compose_assoc : forall A B C D: Obj, forall F:{f:Arrow -> Obj & f source = C /\ f target = D}, forall G:{f:Arrow -> Obj & f source = B /\ f target = C}, forall H:{f:Arrow -> Obj & f source = A /\ f target = B}, (composeArrow _ _ _ F (composeArrow _ _ _ G H)) = (composeArrow _ _ _ (composeArrow _ _ _ F G) H)
}.

Lemma composeArrowType : forall A B C : Type,
  {f : Arrow -> Type & f source = B /\ f target = C} ->
  {g : Arrow -> Type & g source = A /\ g target = B} ->
  {h : Arrow -> Type & h source = A /\ h target = C}.
intros A B C.
rewrite dependent_walking.
rewrite dependent_walking.
rewrite dependent_walking.
apply compose.
Defined.

Definition TypeCat : Category.
apply (mkCat Type composeArrowType).
intros A B F.
destruct F.
destruct a.
rewrite <- e.
rewrite <- e0.
clear e.
clear e0.
rewrite <- (walking_eval x).
cbv.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs.object.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope Z.
Local Open Scope logic.

Definition object_invariant := list Z -> val -> mpred.

Definition tobject := tptr (Tstruct _object noattr).

Definition reset_spec (instance: object_invariant) :=
  WITH self: val, history: list Z
  PRE [ tobject]
          PROP ()
          PARAMS (self)
          SEP (instance history self)
  POST [ tvoid ]
          PROP() RETURN () SEP(instance nil self).

Definition twiddle_spec (instance: object_invariant) :=
  WITH self: val, i: Z, history: list Z
  PRE [ tobject, tint]
          PROP (0 < i <= Int.max_signed / 4;
                0 <= fold_right Z.add 0 history <= Int.max_signed / 4)
          PARAMS (self; Vint (Int.repr i))
          SEP (instance history self)
  POST [ tint ]
      EX v: Z,
          PROP(2* fold_right Z.add 0 history < v <= 2* fold_right Z.add 0 (i::history))
          RETURN (Vint (Int.repr v))
          SEP(instance (i::history) self).

Definition object_methods (instance: object_invariant) (mtable: val) : mpred :=
  EX sh: share, EX reset: val, EX twiddle: val,
  !! readable_share sh &&
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset,twiddle) mtable.

Lemma object_methods_local_facts: forall instance p,
  object_methods instance p |-- !! isptr p.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.
entailer!.
Qed.
#[export] Hint Resolve object_methods_local_facts : saturate_local.

Definition object_mpred (history: list Z) (self: val) : mpred :=
  EX instance: object_invariant, EX mtable: val,
       (object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self*
     instance history self).

Definition foo_invariant : object_invariant :=
  (fun (history: list Z) p =>
    withspacer Ews (sizeof size_t + sizeof tint) (2 * sizeof size_t) (field_at Ews (Tstruct _foo_object noattr)
            [StructField _data] (Vint (Int.repr (2*fold_right Z.add 0 history)))) p
      *  malloc_token Ews (Tstruct _foo_object noattr) p).

Definition foo_reset_spec :=
 DECLARE _foo_reset (reset_spec foo_invariant).

Definition foo_twiddle_spec :=
 DECLARE _foo_twiddle  (twiddle_spec foo_invariant).

Definition make_foo_spec :=
 DECLARE _make_foo
 WITH gv: globals
 PRE [ ]
    PROP () PARAMS() GLOBALS (gv)
    SEP (mem_mgr gv; object_methods foo_invariant (gv _foo_methods))
 POST [ tobject ]
    EX p: val, PROP () RETURN (p)
     SEP (mem_mgr gv; object_mpred nil p; object_methods foo_invariant (gv _foo_methods)).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     EX i:Z, PROP(0<=i<=6) RETURN (Vint (Int.repr i)) SEP(TT).

Definition Gprog : funspecs :=   ltac:(with_library prog [
    foo_reset_spec; foo_twiddle_spec; make_foo_spec; main_spec]).

Lemma object_mpred_i:
  forall (history: list Z) (self: val) (instance: object_invariant) (mtable: val),
    object_methods instance mtable *
     field_at Ews (Tstruct _object noattr) [StructField _mtable] mtable self *
     instance history self
    |-- object_mpred history self.
Proof.
intros. unfold object_mpred. Exists instance mtable; auto.
Qed.

Lemma body_foo_reset: semax_body Vprog Gprog f_foo_reset foo_reset_spec.
Proof.
unfold foo_reset_spec, foo_invariant, reset_spec.
start_function.
unfold withspacer; simpl; Intros.
forward.  (* self->data=0; *)
entailer!!.
all: unfold withspacer; simpl; entailer!!.  (* needed if Archi.ptr64=true *)
Qed.

Lemma body_foo_twiddle: semax_body Vprog Gprog f_foo_twiddle foo_twiddle_spec.
Proof.
unfold foo_twiddle_spec, foo_invariant, twiddle_spec.
start_function.
unfold withspacer; simpl.
Intros.
forward.  (* d = self->data; *)
forward.  (* self -> data = d+2*i; *)
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!!.
forward.  (* return d+i; *)
simpl.
 set (j:= Int.max_signed / 4) in *; compute in j; subst j.
 forget (fold_right Z.add 0 history) as h.
 entailer!!.
Exists (2 * fold_right Z.add 0 history + i).
simpl;
entailer!!.
rewrite Z.mul_add_distr_l, Z.add_comm.
unfold withspacer; simpl.
entailer!!.
Qed.

Lemma split_object_methods:
  forall instance m,
    object_methods instance m |-- object_methods instance m * object_methods instance m.
Proof.
intros.
unfold object_methods.
Intros sh reset twiddle.

Exists (fst (slice.cleave sh)) reset twiddle.
Exists (snd (slice.cleave sh)) reset twiddle.
rewrite (split_func_ptr' (reset_spec instance) reset) at 1.
rewrite (split_func_ptr' (twiddle_spec instance) twiddle) at 1.
entailer!!.
split.
apply slice.cleave_readable1; auto.
apply slice.cleave_readable2; auto.
rewrite (data_at_share_join (fst (slice.cleave sh)) (snd (slice.cleave sh)) sh).
auto.
apply slice.cleave_join.
Qed.

Lemma body_make_foo: semax_body Vprog Gprog f_make_foo make_foo_spec.
Proof.
unfold make_foo_spec.
start_function.
forward_call (Tstruct _foo_object noattr, gv).
Intros p.
forward_if
  (PROP ( )
   LOCAL (temp _p p; gvars gv)
   SEP (mem_mgr gv;
          malloc_token Ews (Tstruct _foo_object noattr) p;
          data_at_ Ews (Tstruct _foo_object noattr) p;
          object_methods foo_invariant (gv _foo_methods))).
*
change (EqDec_val p nullval) with (eq_dec p nullval).
if_tac; entailer!!.
*
forward_call 1.
contradiction.
*
rewrite if_false by auto.
Intros.
forward.  (*  /*skip*/;  *)
entailer!!.
*
unfold data_at_, field_at_, default_val; simpl.
forward. (* p->mtable = &foo_methods; *)
forward. (* p->data = 0; *)
forward. (* return (struct object * ) p; *)
Exists p.
unfold object_mpred.
Exists foo_invariant (gv _foo_methods).
sep_apply (split_object_methods foo_invariant (gv _foo_methods)).
unfold foo_invariant at 4.
entailer!!.
simpl.
unfold_data_at (field_at _ _ nil _ p).
cancel.
unfold withspacer; simpl.
rewrite !field_at_data_at.
simpl.
apply derives_refl'.
rewrite <- ?sepcon_assoc. (* needed if Archi.ptr64=true *)
rewrite !field_compatible_field_address; auto with field_compatible.
clear - H.
(* TODO: simplify the following proof. *)
destruct p; try contradiction.
destruct H as [AL SZ].
repeat split; auto.
simpl in *.  unfold sizeof in *; simpl in *; lia.
eapply align_compatible_rec_Tstruct; [reflexivity.. |].
simpl co_members; intros.
simpl in H.
if_tac in H; [| inv H].
inv H. inv H0.
eapply align_compatible_rec_by_value.
reflexivity.
rewrite Z.add_0_r.
simpl.
unfold natural_alignment in AL.
eapply Z.divide_trans; [ | apply AL].
apply prove_Zdivide.
reflexivity.
left; auto.
Qed.

Lemma make_object_methods:
  forall sh instance reset twiddle mtable,
  readable_share sh ->
  func_ptr' (reset_spec instance) reset *
  func_ptr' (twiddle_spec instance) twiddle *
  data_at sh (Tstruct _methods noattr) (reset, twiddle) mtable
  |-- object_methods instance mtable.
Proof.
  intros.
  unfold object_methods.
  Exists sh reset twiddle.
  entailer!!.
Qed.

Ltac method_call witness hist' result :=
repeat apply seq_assoc1;
match goal with
   |- semax _ (PROPx _ (LOCALx ?Q (SEPx ?R)))
            (Ssequence (Sset ?mt (Efield (Ederef (Etempvar ?x _)  _) _ _))
                 _) _  =>
    match Q with context [temp ?x ?x'] =>
     match R with context [object_mpred _ x'] =>
          let instance := fresh "instance" in let mtable := fresh "mtable" in
          unfold object_mpred; Intros instance mtable;
          forward;
          unfold object_methods at 1;
          let sh := fresh "sh" in let r := fresh "r" in let t := fresh "t" in
          Intros sh r t;
          forward;
          forward_call witness;
          [ .. | try Intros result;
                  sep_apply (make_object_methods sh instance r t mtable); [ auto .. | ];
                  sep_apply (object_mpred_i hist' x' instance mtable);
                  deadvars; try clear dependent sh; try clear r; try clear t
           ]
    end end
end.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
(* assert_gvar _foo_methods. (* TODO: this is needed for a field_compatible later on *) *)
fold noattr cc_default.
(* 0. This part should be handled automatically by start_function *)
gather_SEP (mapsto _ _ _ _) (data_at _ _ _ _);
replace_SEP 0 (data_at Ews (Tstruct _methods noattr)
   (gv _foo_reset, gv _foo_twiddle) (gv _foo_methods)). {
  entailer!.
  unfold_data_at (data_at _ (Tstruct _methods _) _ (gv _foo_methods)).
  rewrite <- mapsto_field_at with (gfs := [StructField _twiddle]) (v:= (gv _foo_twiddle))
  by  auto with field_compatible.
  rewrite field_at_data_at.  rewrite !field_compatible_field_address by auto with field_compatible.
  rewrite !isptr_offset_val_zero by auto.
  cancel.
}

(* 1. Prove that [mtable] is a proper method-table for foo-objects *)

make_func_ptr _foo_twiddle.
make_func_ptr _foo_reset.
sep_apply (make_object_methods Ews foo_invariant(gv _foo_reset) (gv _foo_twiddle) (gv _foo_methods)); auto.

(* 2. Build an instance of class [foo], called [p] *)
forward_call (* p = make_foo(); *)
        gv.
Intros p.
assert_PROP (p<>Vundef) by entailer!.
(* Illustration of an alternate method to prove the method calls.
   Method 1:  comment out lines AA and BB and the entire range CC-DD.
   Method 2:  comment out lines AA-BB, inclusive.
*)

(* AA *) try (tryif
  (method_call (p, @nil Z) (@nil Z) whatever;
   method_call (p, 3, @nil Z) [3%Z] i;
     [simpl; computable | ])
(* BB *)  then fail else fail 99)
  .

(* CC *)
(* 4. first method-call *)
unfold object_mpred.
Intros instance mtable0.
forward. (*  mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward. (* p_reset = mtable->reset; *)
forward_call (* p_reset(p); *)
      (p, @nil Z).
(* Finish the method-call by regathering the object p back together *)
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [] p instance mtable0).
deadvars!. clear.

(* 5. second method-call *)
unfold object_mpred.
Intros instance mtable0.
forward.  (* mtable = p->mtable; *)
unfold object_methods at 1.
Intros sh r0 t0.
forward.   (* p_twiddle = mtable->twiddle; *)
assert_PROP (p<>Vundef) by entailer!.
forward_call (* i = p_twiddle(p,3); *)
      (p, 3, @nil Z).
  simpl. computable.
Intros i.
simpl in H0.
sep_apply (make_object_methods sh instance r0 t0 mtable0); auto.
sep_apply (object_mpred_i [3] p instance mtable0).
deadvars!.
simpl in H1.

(* DD *)

(* 6. return *)
forward.  (* return i; *)
Exists i; entailer!!.
Qed.


(* generated by Ott 0.10.17 ***locally nameless*** from: terms.ott *)

Require Import Metatheory.

(** syntax *)
Definition x := var.
Definition l := atom.

Inductive k : Set :=
 | k_true : k
 | k_false : k
 | k_others : k.

Inductive B : Set :=
 | B_bool : B
 | B_others : B.

Inductive b : Set :=
 | b_blame : l -> b.

Inductive s : Set :=
 | s_var_b : nat -> s
 | s_var_f : x -> s
 | s_const : k -> s
 | s_lam : SS -> s -> s
 | s_app : s -> s -> s
 | s_blame : b -> s
 | s_cast : SS -> SS -> l -> s
 | s_check : SS -> s -> k -> l -> s
with SS : Set :=
 | SS_refinement : B -> s -> SS
 | SS_darrow : SS -> SS -> SS.

Inductive F : Set :=
 | F_appl : s -> F
 | F_appr : s -> F
 | F_check : SS -> k -> l -> F.

(* EXPERIMENTAL *)

(** subrules *)
Definition is_FS_of_SS (SS_6:SS) : Prop :=
  match SS_6 with
  | (SS_refinement B5 s5) => False
  | (SS_darrow SS1 SS2) => (True)
end.

Definition is_h_of_s (s_6:s) : Prop :=
  match s_6 with
  | (s_var_b nat) => False
  | (s_var_f x5) => False
  | (s_const k5) => False
  | (s_lam SS5 s5) => False
  | (s_app s5 s') => False
  | (s_blame b5) => False
  | (s_cast SS1 SS2 l5) => ((is_FS_of_SS SS1) /\ (is_FS_of_SS SS2))
  | (s_check SS5 s5 k5 l5) => False
end.

Fixpoint is_w_of_s (s_6:s) : Prop :=
  match s_6 with
  | (s_var_b nat) => False
  | (s_var_f x5) => False
  | (s_const k5) => (True)
  | (s_lam SS5 s5) => (True)
  | (s_app s5 s') => ((is_h_of_s s5) /\ (is_w_of_s s'))
  | (s_blame b5) => False
  | (s_cast SS1 SS2 l5) => (True)
  | (s_check SS5 s5 k5 l5) => False
end.

Definition is_q_of_s (s_6:s) : Prop :=
  match s_6 with
  | (s_var_b nat) => False
  | (s_var_f x5) => False
  | (s_const k5) => (True)
  | (s_lam SS5 s5) => (True)
  | (s_app s5 s') => ((is_h_of_s s5) /\ (is_w_of_s s'))
  | (s_blame b5) => (True)
  | (s_cast SS1 SS2 l5) => (True)
  | (s_check SS5 s5 k5 l5) => False
end.

(** opening up abstractions *)
Fixpoint open_s_wrt_s_rec (k:nat) (s_6:s) (s__7:s) {struct s__7}: s :=
  match s__7 with
  | (s_var_b nat) =>
      match lt_eq_lt_dec nat k with
        | inleft (left _) => s_var_b nat
        | inleft (right _) => s_6
        | inright _ => s_var_b (nat - 1)
      end
  | (s_var_f x5) => s_var_f x5
  | (s_const k5) => s_const k5
  | (s_lam SS5 s5) => s_lam (open_SS_wrt_s_rec k s_6 SS5) (open_s_wrt_s_rec (S k) s_6 s5)
  | (s_app s5 s') => s_app (open_s_wrt_s_rec k s_6 s5) (open_s_wrt_s_rec k s_6 s')
  | (s_blame b5) => s_blame b5
  | (s_cast SS1 SS2 l5) => s_cast (open_SS_wrt_s_rec k s_6 SS1) (open_SS_wrt_s_rec k s_6 SS2) l5
  | (s_check SS5 s5 k5 l5) => s_check (open_SS_wrt_s_rec k s_6 SS5) (open_s_wrt_s_rec k s_6 s5) k5 l5
end
with open_SS_wrt_s_rec (k:nat) (s_6:s) (SS_6:SS) {struct SS_6}: SS :=
  match SS_6 with
  | (SS_refinement B5 s5) => SS_refinement B5 (open_s_wrt_s_rec (S k) s_6 s5)
  | (SS_darrow SS1 SS2) => SS_darrow (open_SS_wrt_s_rec k s_6 SS1) (open_SS_wrt_s_rec (S k) s_6 SS2)
end.

Definition open_F_wrt_s_rec (k:nat) (s_6:s) (F5:F) : F :=
  match F5 with
  | (F_appl s5) => F_appl (open_s_wrt_s_rec k s_6 s5)
  | (F_appr s5) => F_appr (open_s_wrt_s_rec k s_6 s5)
  | (F_check SS5 k5 l5) => F_check (open_SS_wrt_s_rec k s_6 SS5) k5 l5
end.

Definition open_SS_wrt_s s_6 SS_6 := open_SS_wrt_s_rec 0 SS_6 s_6.

Definition open_s_wrt_s s_6 s__7 := open_s_wrt_s_rec 0 s__7 s_6.

Definition open_F_wrt_s s_6 F5 := open_F_wrt_s_rec 0 F5 s_6.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_s_SS *)
Inductive lc_s : s -> Prop :=    (* defn lc_s *)
 | lc_s_var_f : forall (x5:x),
     (lc_s (s_var_f x5))
 | lc_s_const : forall (k5:k),
     (lc_s (s_const k5))
 | lc_s_lam : forall (SS5:SS) (s5:s),
     (lc_SS SS5) ->
      ( forall x5 , lc_s  ( open_s_wrt_s s5 (s_var_f x5) )  )  ->
     (lc_s (s_lam SS5 s5))
 | lc_s_app : forall (s5 s':s),
     (lc_s s5) ->
     (lc_s s') ->
     (lc_s (s_app s5 s'))
 | lc_s_blame : forall (b5:b),
     (lc_s (s_blame b5))
 | lc_s_cast : forall (SS1 SS2:SS) (l5:l),
     (lc_SS SS1) ->
     (lc_SS SS2) ->
     (lc_s (s_cast SS1 SS2 l5))
 | lc_s_check : forall (SS5:SS) (s5:s) (k5:k) (l5:l),
     (lc_SS SS5) ->
     (lc_s s5) ->
     (lc_s (s_check SS5 s5 k5 l5))
with lc_SS : SS -> Prop :=    (* defn lc_SS *)
 | lc_SS_refinement : forall (B5:B) (s5:s),
      ( forall x5 , lc_s  ( open_s_wrt_s s5 (s_var_f x5) )  )  ->
     (lc_SS (SS_refinement B5 s5))
 | lc_SS_darrow : forall (SS1 SS2:SS),
     (lc_SS SS1) ->
      ( forall x5 , lc_SS  ( open_SS_wrt_s SS2 (s_var_f x5) )  )  ->
     (lc_SS (SS_darrow SS1 SS2)).

(* defns LC_F *)
Inductive lc_F : F -> Prop :=    (* defn lc_F *)
 | lc_F_appl : forall (s5:s),
     (lc_s s5) ->
     (lc_F (F_appl s5))
 | lc_F_appr : forall (s5:s),
     (lc_s s5) ->
     (lc_F (F_appr s5))
 | lc_F_check : forall (SS5:SS) (k5:k) (l5:l),
     (lc_SS SS5) ->
     (lc_F (F_check SS5 k5 l5)).

(** free variables *)
Fixpoint sfv_s (s_6:s) : vars :=
  match s_6 with
  | (s_var_b nat) => {}
  | (s_var_f x5) => {{x5}}
  | (s_const k5) => {}
  | (s_lam SS5 s5) => (sfv_SS SS5) \u (sfv_s s5)
  | (s_app s5 s') => (sfv_s s5) \u (sfv_s s')
  | (s_blame b5) => {}
  | (s_cast SS1 SS2 l5) => (sfv_SS SS1) \u (sfv_SS SS2)
  | (s_check SS5 s5 k5 l5) => (sfv_SS SS5) \u (sfv_s s5)
end
with sfv_SS (SS_6:SS) : vars :=
  match SS_6 with
  | (SS_refinement B5 s5) => (sfv_s s5)
  | (SS_darrow SS1 SS2) => (sfv_SS SS1) \u (sfv_SS SS2)
end.

Definition sfv_F (F5:F) : vars :=
  match F5 with
  | (F_appl s5) => (sfv_s s5)
  | (F_appr s5) => (sfv_s s5)
  | (F_check SS5 k5 l5) => (sfv_SS SS5)
end.

(** substitutions *)
Fixpoint ssubst_s (s_6:s) (y5:x) (s__7:s) {struct s__7} : s :=
  match s__7 with
  | (s_var_b nat) => s_var_b nat
  | (s_var_f x5) => (if eq_var x5 y5 then s_6 else (s_var_f x5))
  | (s_const k5) => s_const k5
  | (s_lam SS5 s5) => s_lam (ssubst_SS s_6 y5 SS5) (ssubst_s s_6 y5 s5)
  | (s_app s5 s') => s_app (ssubst_s s_6 y5 s5) (ssubst_s s_6 y5 s')
  | (s_blame b5) => s_blame b5
  | (s_cast SS1 SS2 l5) => s_cast (ssubst_SS s_6 y5 SS1) (ssubst_SS s_6 y5 SS2) l5
  | (s_check SS5 s5 k5 l5) => s_check (ssubst_SS s_6 y5 SS5) (ssubst_s s_6 y5 s5) k5 l5
end
with ssubst_SS (s_6:s) (y5:x) (SS_6:SS) {struct SS_6} : SS :=
  match SS_6 with
  | (SS_refinement B5 s5) => SS_refinement B5 (ssubst_s s_6 y5 s5)
  | (SS_darrow SS1 SS2) => SS_darrow (ssubst_SS s_6 y5 SS1) (ssubst_SS s_6 y5 SS2)
end.

Definition ssubst_F (s_6:s) (y5:x) (F5:F) : F :=
  match F5 with
  | (F_appl s5) => F_appl (ssubst_s s_6 y5 s5)
  | (F_appr s5) => F_appr (ssubst_s s_6 y5 s5)
  | (F_check SS5 k5 l5) => F_check (ssubst_SS s_6 y5 SS5) k5 l5
end.

(* OTT generates a tactic that mentions env, so even though
   there are no environments here, we have to have the type
   available. *)
Parameter env : Set.

(* denotations are only defined on constants. *)
Parameter denot : k -> k -> s.

(* I'd like to use 'S' for types (like the paper), but that
   conflicts with nat's S in the generated code. *)
Parameter tyh   : k -> SS.

(* I don't know why OTT generates calls to these but doesn't
   generate the definitions. But they're trivial. *)
Definition lc_B (B1 : B) := True.
Definition lc_k (k1 : k) := True.

(* Plugging an evaluation context with a term. *)
Definition Fplug (F1 : F) (s1 : s) :=
  match F1 with
  | F_appl s2 => s_app s1 s2
  | F_appr s2 => s_app s2 s1
  | F_check SS k l => s_check SS s1 k l
  end.

(** definitions *)

(* defns Jctx *)
Inductive valid_ctx : F -> Prop :=    (* defn valid_ctx *)
 | valid_appl : forall (s5:s),
     lc_s s5 ->
     valid_ctx (F_appl s5)
 | valid_appr : forall (w5:s),
     is_w_of_s w5 ->
     is_w_of_s w5 ->
     lc_s w5 ->
     valid_ctx (F_appr w5)
 | valid_check : forall (SS5:SS) (k5:k) (l5:l),
     lc_SS SS5 ->
     lc_k k5 ->
     valid_ctx (F_check SS5 k5 l5).

(* defns Joph *)
Inductive reduceh : s -> s -> Prop :=    (* defn reduceh *)
 | F_Const : forall (k5 k':k),
     lc_k k5 ->
     lc_k k' ->
     reduceh (s_app (s_const k5) (s_const k'))  (denot  k5   k' )
 | F_Beta : forall (SS5:SS) (s12 w2:s),
     is_w_of_s w2 ->
      lc_s   ( (s_lam SS5 s12) )   ->
      lc_s  w2  ->
     reduceh (s_app  ( (s_lam SS5 s12) )  w2)  (open_s_wrt_s  s12   w2 )
 | F_CCheck : forall (B5:B) (s1 s2:s) (l5:l) (k5:k),
     lc_k k5 ->
      lc_SS  (SS_refinement B5 s1)  ->
      lc_SS  (SS_refinement B5 s2)  ->
     reduceh (s_app (s_cast (SS_refinement B5 s1) (SS_refinement B5 s2) l5) (s_const k5)) (s_check (SS_refinement B5 s2)  (open_s_wrt_s  s2   (s_const k5) )  k5 l5)
 | F_OK : forall (SS5:SS) (k5:k) (l5:l),
     lc_k k5 ->
      lc_SS  SS5  ->
     reduceh (s_check SS5 (s_const k_true) k5 l5) (s_const k5)
 | F_Fail : forall (SS5:SS) (k5:k) (l5:l),
     lc_k k5 ->
      lc_SS  SS5  ->
     reduceh (s_check SS5 (s_const k_false) k5 l5) (s_blame (b_blame l5))
 | F_CDecomp : forall (SS11 SS12 SS21 SS22:SS) (l5:l) (w' w5:s),
     is_w_of_s w5 ->
     is_w_of_s w' ->
     is_w_of_s w5 ->
     lc_s w5 ->
      lc_SS  (SS_darrow SS11 SS12)  ->
      lc_SS  (SS_darrow SS21 SS22)  ->
      lc_s  w'  ->
     reduceh (s_app  ( (s_app (s_cast (SS_darrow SS11 SS12) (SS_darrow SS21 SS22) l5) w5) )  w') (s_app (s_cast  (   open_SS_wrt_s  SS12   (s_app (s_cast SS21 SS11 l5) w')   )   (   open_SS_wrt_s  SS22   w'   )  l5)  ( (s_app w5  ( (s_app (s_cast SS21 SS11 l5) w') ) ) ) ).

(* defns JophT *)
Inductive steph : s -> s -> Prop :=    (* defn steph *)
 | F_Reduce : forall (s1 s2:s),
     reduceh s1 s2 ->
     steph s1 s2
 | F_Compat : forall (F5:F) (s1 s2:s),
     valid_ctx F5 ->
     steph s1 s2 ->
     steph  (Fplug  F5   s1 )   (Fplug  F5   s2 )
 | F_Blame : forall (F5:F) (l5:l),
     valid_ctx F5 ->
     steph  (Fplug  F5   (s_blame (b_blame l5)) )  (s_blame (b_blame l5)).

(* defns JophM *)
Inductive evalh : s -> s -> Prop :=    (* defn evalh *)
 | F_Refl : forall (s5:s),
     lc_s s5 ->
     evalh s5 s5
 | F_Step : forall (s5 s'' s':s),
     steph s5 s' ->
     evalh s' s'' ->
     evalh s5 s''.

(* defns Jparred *)
Inductive parreds : s -> s -> Prop :=    (* defn parreds *)
 | P_Refl : forall (s5:s),
     lc_s s5 ->
     parreds s5 s5
 | P_RConst : forall (k5:k) (w5:s) (k':k),
     is_w_of_s w5 ->
     lc_k k5 ->
     parreds w5 (s_const k') ->
     parreds (s_app (s_const k5) w5)  (denot  k5   k' )
 | P_RBeta : forall (L:vars) (SS5:SS) (s12 w2 s12' w2':s),
     is_w_of_s w2 ->
     is_w_of_s w2' ->
     lc_SS SS5 ->
      ( forall x5 , x5 \notin  L  -> parreds  ( open_s_wrt_s s12 (s_var_f x5) )   (open_s_wrt_s  s12'   (s_var_f x5) )  )  ->
     parreds w2 w2' ->
     parreds (s_app  ( (s_lam SS5 s12) )  w2)  (open_s_wrt_s  s12'   w2' )
 | P_RCCheck : forall (L:vars) (B5:B) (s1 s2:s) (l5:l) (k5:k) (s2':s),
     lc_k k5 ->
      lc_SS  (SS_refinement B5 s1)  ->
      ( forall x5 , x5 \notin  L  -> parreds  ( open_s_wrt_s s2 (s_var_f x5) )   ( open_s_wrt_s s2' (s_var_f x5) )  )  ->
     parreds (s_app (s_cast (SS_refinement B5 s1) (SS_refinement B5 s2) l5) (s_const k5)) (s_check (SS_refinement B5 s2')  (open_s_wrt_s  s2'   (s_const k5) )  k5 l5)
 | P_ROK : forall (SS5:SS) (k5:k) (l5:l),
     lc_k k5 ->
      lc_SS  SS5  ->
     parreds (s_check SS5 (s_const k_true) k5 l5) (s_const k5)
 | P_RFail : forall (SS5:SS) (k5:k) (l5:l),
     lc_k k5 ->
      lc_SS  SS5  ->
     parreds (s_check SS5 (s_const k_false) k5 l5) (s_blame (b_blame l5))
 | P_RCDecomp : forall (L:vars) (SS11 SS12 SS21 SS22:SS) (l5:l) (w1 w2:s) (SS12' SS21' SS11':SS) (w2':s) (SS22':SS) (w1':s),
     is_w_of_s w1 ->
     is_w_of_s w2 ->
     is_w_of_s w2' ->
     is_w_of_s w1' ->
     parredSS SS11 SS11' ->
      ( forall x5 , x5 \notin  L  -> parredSS  ( open_SS_wrt_s SS12 (s_var_f x5) )   (   open_SS_wrt_s  SS12'   (s_var_f x5)   )  )  ->
     parredSS SS21 SS21' ->
      ( forall x5 , x5 \notin  L  -> parredSS  ( open_SS_wrt_s SS22 (s_var_f x5) )   (   open_SS_wrt_s  SS22'   (s_var_f x5)   )  )  ->
     parreds w1 w1' ->
     parreds w2 w2' ->
     parreds (s_app  ( (s_app (s_cast (SS_darrow SS11 SS12) (SS_darrow SS21 SS22) l5) w1) )  w2) (s_app (s_cast  (   open_SS_wrt_s  SS12'   (s_app (s_cast SS21' SS11' l5) w2')   )   (   open_SS_wrt_s  SS22'   w2'   )  l5)  ( (s_app w1'  ( (s_app (s_cast SS21' SS11' l5) w2') ) ) ) )
 | P_Lam : forall (L:vars) (SS1:SS) (s12:s) (SS1':SS) (s12':s),
     parredSS SS1 SS1' ->
      ( forall x5 , x5 \notin  L  -> parreds  ( open_s_wrt_s s12 (s_var_f x5) )   ( open_s_wrt_s s12' (s_var_f x5) )  )  ->
     parreds (s_lam SS1 s12) (s_lam SS1' s12')
 | P_App : forall (s1 s2 s1' s2':s),
     parreds s1 s1' ->
     parreds s2 s2' ->
     parreds (s_app s1 s2) (s_app s1' s2')
 | P_Cast : forall (SS1 SS2:SS) (l5:l) (SS1' SS2':SS),
     parredSS SS1 SS1' ->
     parredSS SS2 SS2' ->
     parreds (s_cast SS1 SS2 l5) (s_cast SS1' SS2' l5)
 | P_Check : forall (SS5:SS) (s5:s) (k5:k) (l5:l) (SS':SS) (s':s),
     lc_k k5 ->
     parredSS SS5 SS' ->
     parreds s5 s' ->
     parreds (s_check SS5 s5 k5 l5) (s_check SS' s' k5 l5)
 | P_Blame : forall (F5:F) (l5:l),
     valid_ctx F5 ->
     parreds  (Fplug  F5   (s_blame (b_blame l5)) )  (s_blame (b_blame l5))
with parredSS : SS -> SS -> Prop :=    (* defn parredSS *)
 | P_SSRefl : forall (SS5:SS),
     lc_SS SS5 ->
     parredSS SS5 SS5
 | P_SSRefine : forall (L:vars) (B5:B) (s5 s':s),
     lc_B B5 ->
      ( forall x5 , x5 \notin  L  -> parreds  ( open_s_wrt_s s5 (s_var_f x5) )   ( open_s_wrt_s s' (s_var_f x5) )  )  ->
     parredSS (SS_refinement B5 s5) (SS_refinement B5 s')
 | P_SSFun : forall (L:vars) (SS1 SS2 SS1' SS2':SS),
     parredSS SS1 SS1' ->
      ( forall x5 , x5 \notin  L  -> parredSS  ( open_SS_wrt_s SS2 (s_var_f x5) )   ( open_SS_wrt_s SS2' (s_var_f x5) )  )  ->
     parredSS (SS_darrow SS1 SS2) (SS_darrow SS1' SS2').

(* defns JparredMs *)
Inductive parredsrs : s -> s -> Prop :=    (* defn parredsrs *)
 | P_ssRefl : forall (s5:s),
     lc_s s5 ->
     parredsrs s5 s5
 | P_ssStep : forall (s5 s'' s':s),
     parreds s5 s' ->
     parredsrs s' s'' ->
     parredsrs s5 s''.

(* defns JparredMSS *)
Inductive parredSrs : SS -> SS -> Prop :=    (* defn parredSrs *)
 | P_SsRefl : forall (SS5:SS),
     lc_SS SS5 ->
     parredSrs SS5 SS5
 | P_SsStep : forall (SS5 SS'' SS':SS),
     parredSS SS5 SS' ->
     parredSrs SS' SS'' ->
     parredSrs SS5 SS''.

(** infrastructure *)

(* additional definitions *)

(* instanciation of tactics *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : vars => x) in
  let B := gather_atoms_with (fun x : var => {{ x }}) in
  let D1 := gather_atoms_with (fun x => sfv_SS x) in
  let D2 := gather_atoms_with (fun x => sfv_s x) in
  let D3 := gather_atoms_with (fun x => sfv_F x) in
  constr:(A \u B \u D1 \u D2 \u D3).

Hint Constructors valid_ctx reduceh steph evalh parreds parredSS parredsrs parredSrs lc_s lc_SS lc_F.


(* admits: 14 + 2

- front ~ FRONT, back ~ BACK <-- have paper proof but am stuck
   - make following code compile

- SHA proofs related to generate_and_pad
   - pushed 2 admits back to sha_padding_lemma (InBlocks corr + positive n)

- range: bytes in range
- pad + intlist_to_Zlist preserve in range, fix the Forall

------

- modules
- linking proofs

*)

Set Implicit Arguments.

(* Require Import Bvector. *)
Require Import List. Import ListNotations.
Require Import Arith.

Require Import HMAC_functional_prog_Z.
Require Import Integers.
Require Import Coqlib.
Require Import sha_padding_lemmas.
Require Import functional_prog.
Require Import hmac_common_lemmas.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import SHA256.
Require Import ByteBitRelations.
Require Import XorCorrespondence.
Require Import HMAC_functional_prog_Z. (* TODO remove? *)
Require Import HMAC_common_defs.
(* TODO remove useless imports *)

Require Import Coq.Program.Basics. (* for function composition: ∘ *)

Module HMAC_Pad.

Local Open Scope program_scope.

Section HMAC.

(* b = block size
   c = digest (output) size
   p = padding = b - c (fixed) *)
  Variable c p : nat.
  Definition b := (c + p)%nat.

  (* The compression function *)
  Variable h : Blist -> Blist -> Blist.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Blist.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Print fold_left.
  Locate fold_left.

  Definition h_star k (m : Blist) :=
    hash_blocks_bits h k m.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  (* Check hash_words. *)
  Check h_star.

  (* NOTE: this is the new design without fpad TODO *)
  (* NOTE: this is the new design with concat and with two hash_words_padded *)
  (* Variable splitAndPad : Blist -> list (Blist). *)
  Variable splitAndPad : Blist -> Blist.

  Definition hash_words_padded : Blist -> Blist :=
    hash_words ∘ splitAndPad.

  (* ----- *)

  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  (* constant-length padding. *)
  Variable fpad : Blist.

  Definition app_fpad (x : Blist) : Blist :=
    x ++ fpad.
  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  (* TODO fix this *)
  Definition GNMAC k m :=
    let (k_Out, k_In) := splitList c k in
    h k_Out (h_star_pad k_In m). (* could take head of list *)

  Check GNMAC.
  (*  list bool -> list Blist -> Blist *)
  Check h.
  (* Blist -> Blist -> Blist *)

Check hash_words.               (* list Blist -> Blist *)

  (* The "two-key" version of GHMAC and HMAC. *)
  (* Concatenate (K xor opad) and (K xor ipad) *)
  Definition GHMAC_2K (k : Blist) m :=
    let (k_Out, k_In) := splitList b k in (* concat earlier, then split *)
      let h_in := (hash_words_padded (k_In ++ m)) in
        hash_words_padded (k_Out ++ h_in).

  Definition HMAC_2K (k : Blist) (m : Blist) :=
    (* GHMAC_2K k (splitAndPad m). *)
    GHMAC_2K k m.

Check HMAC_2K.
(* Blist -> Blist -> Blist *)

(* opad and ipad are constants defined in the HMAC spec. *)
Variable opad ipad : Blist.

Print BLxor.

Definition GHMAC (k : Blist) :=
  GHMAC_2K (BLxor k opad ++ BLxor k ipad).

Definition HMAC (k : Blist) :=
  HMAC_2K (BLxor k opad ++ BLxor k ipad).

Check HMAC.

End HMAC.

(* ----------------------------------------------- *)

Definition c:nat := (SHA256_.DigestLength * 8)%nat.
Definition p:=(32 * 8)%nat.

Definition sha_iv : Blist :=
  bytesToBits (SHA256.intlist_to_Zlist SHA256.init_registers).

Check SHA256.hash_blocks.       (* SHA256.registers -> list int -> SHA256.registers *)
Definition sha_h (regs : Blist) (block : Blist) : Blist :=
  bytesToBits (SHA256.intlist_to_Zlist
                 (SHA256.hash_block (SHA256.Zlist_to_intlist (bitsToBytes regs))
                                     (SHA256.Zlist_to_intlist (bitsToBytes block))
              )).

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

Definition convert (l : list int) : list bool :=
  bytesToBits (SHA256.intlist_to_Zlist l).

(* ------------------------------------------------- *)
(* Neat conversion functions (TODO move rest of spec over *)

(*
Definition c := (SHA256_.DigestLength * 8)%nat.
Definition p := (32 * 8)%nat.

Definition intsToBits (l : list int) : list bool :=
  bytesToBits (SHA256.intlist_to_Zlist l).

Definition bitsToInts (l : Blist) : list int :=
  SHA256.Zlist_to_intlist (bitsToBytes l).

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)).
*)

(* -------------------------------------------------------- LEMMAS *)

(* Lemma 1: ++ equivalence on list *)
(* Lemma 2: xor equivalence on list *)
(* Lemma 3: SHA (iterated hash) equivalence on list *)

Lemma concat_equiv :
  forall (l1 : Blist) (l2 : list Z) (m1 : Blist) (m2 : list Z),
    bytes_bits_lists l1 l2
    -> bytes_bits_lists m1 m2
    -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2).
(* bytes_bits_lists l1 l2 -> bytes_bits_lists m1 m2 -> bytes_bits_lists (l1 ++ m1) (l2 ++ m2) *)
Proof.
  intros l1 l2 m1 m2.
  intros fst_eq snd_eq.
  generalize dependent m1. generalize dependent m2.
  induction fst_eq; intros.
  - repeat rewrite app_nil_l.
    apply snd_eq.
  - simpl.
    apply eq_cons.
    + apply IHfst_eq.
      apply snd_eq.
    + apply H.
Qed.

(* --------------------------------- *)

(* Lemma 2 *)

(* Prove that the inner xor lemma is true on at least one example *)
Section Example.

 Definition k:Blist := concat (list_repeat 64 [true; true; false; false; true; false; true; true]).
 Definition K:list Z := list_repeat 64 211.

 Lemma conv : convertByteBits [true; true; false; false; true; false; true; true] 211.
   repeat eexists.
  (* eexists; eexists; eexists; eexists; eexists; eexists; eexists; eexists. *)
  (* split. reflexivity. simpl. reflexivity. *)
 Qed.
 Lemma kKcorrect: bytes_bits_lists k K.
   unfold K, k. simpl.
   repeat constructor; try apply conv.
  Qed.

 Definition ip:Blist := concat (list_repeat 64 [false; true; false; false; true; false; true; true]).
 Definition IP:Z := 210.
 Transparent Byte.repr.

Definition byte_to_64list (byte : byte) : list Z :=
   map Byte.unsigned (HMAC_SHA256.sixtyfour byte).

 Lemma ip_conv : convertByteBits [false; true; false; false; true; false; true; true] 210.
   repeat eexists.
 Qed.
 Lemma ipcorrect: bytes_bits_lists ip (HMAC_SHA256.sixtyfour IP).
   unfold ip, IP. simpl. unfold byte_to_64list, HMAC_SHA256.sixtyfour. simpl.
   repeat constructor; try apply ip_conv.
  Qed.

Lemma ONE: convertByteBits [true; false; false; false; false; false; false; false] 1.
  repeat eexists. Qed.

Lemma inner_fst_equiv_example : exists k (ip  : Blist) K (IP : Z),
                          ((length K) * 8)%nat = (c + p)%nat /\
                          Zlength K = Z.of_nat SHA256_.BlockSize /\
                          (* TODO: first implies this *)
                          bytes_bits_lists k K /\
                          bytes_bits_lists ip (HMAC_SHA256.sixtyfour IP) /\
                          bytes_bits_lists (BLxor k ip)
                                           ((HMAC_SHA256.mkArg (HMAC_SHA256.mkKey K) IP)).

Proof.
  exists k, ip, K, IP. repeat split.
   apply kKcorrect. apply ipcorrect.
  unfold k, K, ip, IP. simpl. unfold BLxor. simpl.
  repeat constructor; apply ONE.
Qed.

(* See XorCorrespondence.v *)

Lemma inner_general_map : forall (ip : Blist) (IP_list : list Z) (k : Blist) (K : list Z),
                            bytes_bits_lists ip IP_list ->
                            bytes_bits_lists k K ->
     bytes_bits_lists (BLxor k ip)
                      (map (fun p0 : Z * Z => Z.lxor (fst p0) (snd p0))
                           (combine K IP_list)).
Proof.
  intros ip IP_list k K ip_eq k_eq.
  unfold BLxor. simpl.
  generalize dependent ip. generalize dependent IP_list.
  induction k_eq; intros.
  - simpl. constructor.
  -
    induction ip_eq.
    +
      simpl. constructor.
    +
      simpl.
      constructor.
      * apply IHk_eq.
        apply ip_eq.            (* ??? *)
      *
        apply xor_correspondence.
        apply H. apply H0.
Qed.

Lemma xor_equiv_Z : forall (xpad  : Blist) (XPAD : Z)
                                           (k : Blist) (K : list Z),
                          bytes_bits_lists xpad (HMAC_SHA256.sixtyfour XPAD) ->
                          ((length K) * 8)%nat = (c + p)%nat ->
                          Zlength K = Z.of_nat SHA256_.BlockSize ->
                          (* TODO: first implies this *)
                          bytes_bits_lists k K ->
                          bytes_bits_lists (BLxor k xpad)
       (HMAC_SHA256.mkArg (HMAC_SHA256.mkKey K) XPAD).
Proof.
  intros xpad XPAD k K.
  intros xpad_equiv len_k zlen_k k_equiv.
  unfold HMAC_SHA256.mkArg, HMAC_SHA256.mkKey.
  Opaque HMAC_SHA256.sixtyfour.
  simpl. rewrite zlen_k. simpl. unfold HMAC_SHA256.zeroPad.
  assert (byte_key_length_blocksize: length K = 64%nat).
    * unfold p, c in *. simpl in *. omega.
  *
    rewrite byte_key_length_blocksize.  simpl.  rewrite app_nil_r.
    apply inner_general_map.

  - apply xpad_equiv.
  - apply k_equiv.
Qed.

Eval compute in Byte.xor (Byte.repr 0) (Byte.repr 100).
Eval compute in Byte.xor (Byte.repr 100) (Byte.repr 100).
Eval compute in Byte.xor (Byte.repr 50) (Byte.repr 5).

End Example.

(* ------------------------------------------------------ *)
(* Lemma 3 *)

(* --- abstract version *)

Parameter A B : Type.
Parameter convert_BA : B -> A.
Parameter convert_AB : A -> B.

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

Definition id {X : A} (x : A) : A := x.
Definition wrap (F : B -> B) : A -> A :=
  convert_BA ∘ F ∘ convert_AB.
Definition roundtrip : B -> B :=
  convert_AB ∘ convert_BA.

Lemma roundtrip_id :
  forall (X : B), convert_AB (convert_BA X) = X.
Proof. Admitted.

Lemma once_eq :
    forall (x : A) (X : B) (f : A -> A) (F : B -> B),
      x = convert_BA X ->
      f = wrap F ->
      X = roundtrip X ->
      f x = convert_BA (F X).
Proof.
  intros x X f F inputs_eq f_def roundtrip_id.
  unfold roundtrip in *.
  rewrite -> inputs_eq.
  rewrite -> f_def.
  unfold wrap in *.
  change ((convert_BA ∘ F ∘ convert_AB) (convert_BA X)) with
    (convert_BA (F ((convert_AB ∘ convert_BA) X))).
  rewrite <- roundtrip_id.
  reflexivity.
Qed.

(* a simplified version of fold_equiv *)
Lemma iterate_equiv :
  forall (x : A) (X : B) (f : A -> A) (F : B -> B) (n : nat),
    x = convert_BA X ->
    f = wrap F ->
    X = roundtrip X ->
    iterate n f x = convert_BA (iterate n F X).
Proof.
  intros. revert x X f F H H0 H1.
  induction n as [ | n']; intros x X f F input_eq func_wrap roundtrip';
  unfold wrap in *; unfold roundtrip in *.
  -
    simpl. apply input_eq.
  -
    simpl.
    pose proof once_eq as once_eq.
    apply once_eq.
    apply IHn'; assumption.
    * unfold wrap. apply func_wrap.
    * symmetry. apply roundtrip_id.
Qed.

(* ----- *)

(* Definition of InBlocks in sha_padding_lemmas *)

Lemma test : InBlocks 512 (list_repeat 512 true).
Proof.
  eapply list_block.
  instantiate (1 := list_repeat 512 true).
  - reflexivity.
  - instantiate (1 := []). rewrite -> app_nil_r. reflexivity.
  - apply list_nil.
Qed.

Lemma splitandpad_equiv : forall (bits : Blist) (bytes : list Z),
                            bytes_bits_lists bits bytes ->
                            bytes_bits_lists
                              (sha_splitandpad bits)
                              (sha_padding_lemmas.pad bytes).
Proof.
  intros bits bytes inputs_eq.
  unfold concat.
  unfold sha_splitandpad.

  apply bytes_bits_ind_comp in inputs_eq.
  rewrite inputs_eq.
  apply bytes_bits_def_eq.
  admit.                        (* padding preserve in-range *)
  admit.
Qed.

Lemma hash_block_equiv :
  forall (bits : Blist) (bytes : list Z)
         (regs : Blist) (REGS : SHA256.registers),
    (length bits)%nat = 512%nat ->
    (length bytes)%nat = 64%nat -> (* removes firstn 16 (Zlist->intlist bytes) *)

    regs = bytesToBits (SHA256.intlist_to_Zlist REGS) ->
    bits = bytesToBits bytes ->

    sha_h regs bits =
    bytesToBits (SHA256.intlist_to_Zlist
                   (SHA256.hash_block REGS
                                      (SHA256.Zlist_to_intlist bytes))).
Proof.
  intros bits bytes regs REGS bits_blocksize bytes_blocksize regs_eq input_eq.
  unfold sha_h.
  apply f_equal.
  apply f_equal.

  rewrite -> regs_eq.
  rewrite -> input_eq.
  rewrite -> bytes_bits_bytes_id.
  rewrite -> bytes_bits_bytes_id.
  rewrite -> pure_lemmas.intlist_to_Zlist_to_intlist.
  reflexivity.
(* TODO: make sure this proof is right / useful *)
  admit. admit.                 (* intlist_to_Zlist preserves in-range *)
Qed.

Lemma front_equiv :
  (* forall (front back : Blist) (FRONT BACK : list int), *)
  forall (back : Blist) (BACK : list int) (front : Blist) (FRONT : list int),
    Forall (fun b : Z => 0 <= b < 256) (SHA256.intlist_to_Zlist (FRONT ++ BACK)) ->
    (length front)%nat = 512%nat ->
    (length FRONT)%nat = 16%nat ->
    InBlocks 512 front ->
    InBlocks 16 FRONT ->
    InBlocks 512 back ->
    InBlocks 16 BACK ->         (* shouldn't need these two *)
    front ++ back = convert (FRONT ++ BACK) ->
    front = convert FRONT.
Proof.
  intros back BACK front FRONT range f_len F_len fblocks Fblocks bblocks Bblocks concat_eq.
  unfold convert in *.
  rewrite -> pure_lemmas.intlist_to_Zlist_app in concat_eq.
  (* can prove InBlocks 512 (convert (FRONT ++ BACK)) *)
  rewrite -> bytesToBits_app in concat_eq.

  (* my proof:
  concat_eq : front ++ back =
              bytesToBits (intlist_to_Zlist FRONT) ++
              bytesToBits (intlist_to_Zlist BACK)

  x0 :: ... :: x511 :: back = x0' :: ... :: x511' :: convert BACK

  BACK is the right length such that the overall lists are the same length
    why? we know that
    full = convert FULL so
    length (front ++ back) = 32 * length (FRONT ++ BACK)
  thus, by list equality, xn = xn' (otherwise, contradiction)

  x0 :: ... :: x511 = x0' :: ... :: x511'
  front = convert FRONT

and back = convert BACK

 *)

  (* but induction on the front needs to be in pairs? can't pair each one-cons
     somehow have to use InBlocks for both AND the length constraint (each is exactly one block)?
   *)
  revert FRONT back BACK Fblocks bblocks Bblocks range f_len F_len concat_eq.
  induction fblocks; intros.
  -
    revert back BACK bblocks Bblocks range f_len F_len concat_eq; induction Fblocks; intros.
    *
      reflexivity.
    *
      simpl in *.
      omega.
  -
    (* what to induct on here? fronts/backs confusing *)
    revert back0 back BACK front full fblocks bblocks Bblocks range f_len F_len concat_eq
           H H0 IHfblocks.
    (* need to figure out how to name induction *)
    induction Fblocks.
    *
      intros.
      simpl in *.
      omega.
    *
      (* look at the intros here *)
      intros.
      rewrite -> H0 in *.
      rewrite -> H2 in *.
      (* frontFinal = front0 ++ back1; FRONTFINAL = front ++ back (confusing...)  *)
(* need to induct on InBlocks front0 and InBlocks front? (don't actually have that,
only the lengths *)
(* wait, consider H1 and f_len..... this is saying that back1 = []?? *)

(* this induction doesn't make any sense since their lengths are fixed.
maybe i should prove it true for a general
InBlocks 16 FRONT
InBlocks 512 front
length front = 32 * length FRONT
both fronts are at the fronts of the list

(these are necessary and sufficient assumptions)

and specialize it to being one block

...and then what to do for the back proof?

 *)

Admitted.

(*

  (* don't induct on the back blocks -- induction case is unprovable *)

  revert front FRONT BACK Bblocks range f_len F_len concat_eq.
  induction bblocks; intros.
  -
    revert front FRONT range f_len F_len concat_eq; induction Bblocks; intros.
    *
      repeat rewrite -> app_nil_r in concat_eq.
      apply concat_eq.
    *
     rewrite -> app_nil_r in concat_eq.
     rewrite -> H0 in concat_eq.
  (* contradiction in length of front0 *)
     admit.
  -
    revert front back full H H0 bblocks IHbblocks front0 FRONT range f_len F_len concat_eq.
    induction Bblocks; intros.
    *
      simpl in concat_eq.
      rewrite -> app_nil_r in concat_eq.
      (* contradiction in length of FRONT *)
      admit.
    *
      specialize (IHbblocks front1 FRONT BACK). (* ??? *)
      apply IHbblocks.
    (* front1, not front0?? *)
      + admit.                    (* range *)
      +
        rewrite -> H0 in *.
        rewrite -> H2 in *.
        (* this isn't right... *)

Admitted.

revert front FRONT range f_len F_len concat_eq;
    induction Bblocks; intros; repeat rewrite -> app_nil_r in *.
  -
    apply concat_eq.
  -
    (* take length of each term in concat_eq, rewrite with f_len, contradiction *)
    admit.
  -                             (* same as before, contradiction with length FRONT *)
    admit.
  -
    (* don't think this is a very good form for ind hyp? *)
    specialize (IHback front FRONT BACK).
    apply IHback; auto.
    * admit.                    (* range *)
    *
      (* inverse induction?? *)
      (* simpl in concat_eq. *)
      (* this is not necessarily true?? since we're cons'ing a single element on each one
         it might be true if back and BACK had some guarantees about their lengths
         and relative lengths

         weird -- it is true for SOME non-empty backs -- e.g. if we inducted on
         InBlocks 512 and InBlocks 16

         or maybe it's always false: concat_eq NEVER implies the conclusion
         so it's not false, but not provable using the given assumption
         might want to use bytes_bits_lists and inwords and induct /
         use properties of bytes_bits_lists to remove the :: and ++
       *)

*)

(* it's more of an iteration theorem than a fold theorem *)
Lemma fold_equiv_blocks :
  forall (l : Blist) (acc : Blist)
         (L : list int) (ACC : list int),
    (* length assumptions about list *)
    (* conversion function: bytesToBits @ SHA256.intlist_to_Zlist *)
      InBlocks 512 l ->         (* TODO: need to prove padding implies this *)
      (* TODO: need to prove that each block corresponds? applied lemma should ask for that *)
      InBlocks 16 L ->
      l = convert L ->
      acc = convert ACC ->
      hash_blocks_bits sha_h acc l = convert (SHA256.hash_blocks ACC L).
Proof.
  intros l acc L ACC bit_blocks bytes_blocks inputs_eq acc_eq.

  (* remember (bytesToBits ∘ SHA256.intlist_to_Zlist) as convert. *)
  (* assert (conv_replace: *)
  (*           forall (x : list int), bytesToBits (SHA256.intlist_to_Zlist x) = convert x). *)
  (*   rewrite -> Heqconvert. reflexivity. *)

  revert acc ACC L inputs_eq acc_eq bytes_blocks.
  induction bit_blocks; intros.
  *
    revert acc ACC inputs_eq acc_eq.
    induction bytes_blocks; intros.

    -                             (* both empty *)
      rewrite -> SHA256.hash_blocks_equation.
      rewrite -> hash_blocks_bits_equation.
      apply acc_eq.

    -
      rewrite -> H0 in *.
      unfold convert in inputs_eq.
      destruct front.
      { inversion H. }
      { simpl in inputs_eq. inversion inputs_eq. }

  *
    revert front back full H H0 bit_blocks IHbit_blocks acc ACC
           inputs_eq acc_eq.
    induction bytes_blocks; intros.
    (* TODO: clear IHbytes_blocks *)

    -
      simpl in inputs_eq.
      rewrite -> H0 in inputs_eq.
      unfold convert in inputs_eq.
      destruct front.
      { inversion H. }
      { simpl in inputs_eq. inversion inputs_eq. }

    -
      rewrite -> SHA256.hash_blocks_equation.
      rewrite -> hash_blocks_bits_equation.
      repeat rewrite -> length_not_emp.

      rewrite -> H0.
      rewrite -> H2.
      (* TODO: generalize these (it's true by hyp) *)
      assert (H_first_512 : firstn 512 (front0 ++ back0) = front0).
        apply firstn_exact. assumption.
      assert (H_skip_512 : skipn 512 (front0 ++ back0) = back0).
        apply skipn_exact. assumption.
      assert (H_first_16 : firstn 16 (front ++ back) = front).
        apply firstn_exact. assumption.
      assert (H_skip_16 : skipn 16 (front ++ back) = back).
        apply skipn_exact. assumption.

      rewrite -> H_first_512.
      rewrite -> H_skip_512.
      rewrite -> H_first_16.
      rewrite -> H_skip_16.

      apply IHbit_blocks; auto; clear IHbytes_blocks IHbit_blocks.
      +                         (* TODO: backs are equivalent *)
        rewrite -> H0 in inputs_eq.
        rewrite -> H2 in inputs_eq.
        (* could refactor out the pose/destruct but leaves more stuff in context *)
        (* pose proof blocks_equiv front0 back0 front back as blocks_equiv. *)
        (* destruct blocks_equiv. *)
        (* apply inputs_eq. *)
        (* apply H4. *)
        admit.
      +
        Check hash_block_equiv.

        pose proof hash_block_equiv as hash_block_equiv.
        specialize (hash_block_equiv front0 (SHA256.intlist_to_Zlist front) acc ACC).
        rewrite -> hash_block_equiv; auto. clear hash_block_equiv.
        rewrite -> pure_lemmas.intlist_to_Zlist_to_intlist.
        (* rewrite -> conv_replace in *. *)
        reflexivity.
        {
          rewrite -> pure_lemmas.length_intlist_to_Zlist.
          rewrite -> H.
          omega.
        }
        {
          (* TODO: prove the fronts are equivalent *)
          rewrite -> H0 in inputs_eq.
          rewrite -> H2 in inputs_eq.
          (* pose proof blocks_equiv front0 back0 front back as blocks_equiv. *)
          (* destruct blocks_equiv. *)
          (* apply inputs_eq. *)
          (* apply H3. *)
          admit.
        }
     +
       rewrite -> H0. rewrite -> app_length. rewrite -> H. omega.
     +
       rewrite -> H2. rewrite -> app_length. rewrite -> H1. omega.
Qed.

(*
- was double induction necessary?
- what about IHbytes_blocks?
- better to rewrite into front and back, then break that up, then apply the *first* induction hypothesis,
  then apply theorem to front

- TODO: prove that they are InBlocks after padding and that front~front0, back~back0
 *)

Lemma SHA_equiv_pad : forall (bits : Blist) (bytes : list Z),
                    bytes_bits_lists bits bytes ->
                    bytes_bits_lists
                      (hash_words_padded sha_h sha_iv sha_splitandpad bits)
                      (SHA256_.Hash bytes).

Proof.
  intros bits bytes input_eq.
  unfold SHA256_.Hash.
  rewrite -> functional_prog.SHA_256'_eq.
  unfold SHA256.SHA_256.
  unfold hash_words_padded.
  change ((hash_words sha_h sha_iv ∘ sha_splitandpad) bits) with
  (hash_words sha_h sha_iv (sha_splitandpad bits)).

  -
    repeat rewrite <- sha_padding_lemmas.pad_compose_equal in *.
    unfold sha_padding_lemmas.generate_and_pad' in *.
    unfold hash_words.
    unfold h_star.

    Check SHA256.hash_blocks_equation.

    pose proof splitandpad_equiv as splitandpad_equiv.
    specialize (splitandpad_equiv bits bytes input_eq).

      apply bytes_bits_comp_ind.
      pose proof fold_equiv_blocks as fold_equiv_blocks. (* delete later *)
      admit.
      (* TODO: in-range preserved by hash_blocks and intlist_to_Zlist *)
      apply fold_equiv_blocks.
      *                         (* padding -> blocks of 512 *)
        unfold sha_splitandpad in *.
        apply bytes_bits_length in input_eq.
        pose proof pad_len_64_nat (bitsToBytes bits) as pad_len_64.
        apply InBlocks_len.
        rewrite -> bytesToBits_len.
        (* eexists. *)
        destruct pad_len_64.
        rewrite -> H.
        exists x.
        omega.
      *
        pose proof pad_len_64_nat bytes as pad_len_64.
        apply InBlocks_len.
        destruct pad_len_64.

        assert (H' : length (pad bytes) = (Z.to_nat WORD * (16 * x))%nat).
          rewrite -> H.
          assert (Z.to_nat WORD = 4%nat) by reflexivity.
          rewrite -> H0.
          omega.

        apply pure_lemmas.length_Zlist_to_intlist in H'.
        rewrite H'.
        eexists x.
        omega.

      * unfold sha_splitandpad.
        unfold convert.
        rewrite -> pure_lemmas.Zlist_to_intlist_to_Zlist.
        f_equal.
        apply bytes_bits_ind_comp in input_eq.
        rewrite -> input_eq.
        reflexivity.
        + admit.                (* bytes in range *)
        +
          pose proof pad_len_64_nat bytes as pad_len_64.
          destruct pad_len_64.
          rewrite -> H.
          assert (four : Z.to_nat WORD = 4%nat) by reflexivity.
          rewrite -> four.
          exists (x * 16)%nat.
          omega.
        + admit.                        (* padding in range *)

     * unfold sha_iv. reflexivity.
Qed.

(* --------------------------------------- *)

(* MAIN THEOREM *)

Theorem HMAC_spec_equiv : forall
                            (K M H : list Z) (OP IP : Z)
                            (k m h : Blist) (op ip : Blist),
  ((length K) * 8)%nat = (c + p)%nat ->
  Zlength K = Z.of_nat SHA256_.BlockSize ->
  (* TODO: first implies this *)
  bytes_bits_lists k K ->
  bytes_bits_lists m M ->
  bytes_bits_lists op (HMAC_SHA256.sixtyfour OP) ->
  bytes_bits_lists ip (HMAC_SHA256.sixtyfour IP) ->
  HMAC c p sha_h sha_iv sha_splitandpad op ip k m = h ->
  HMAC_SHA256.HMAC IP OP M K = H ->
  bytes_bits_lists h H.
Proof.
  intros K M H OP IP k m h op ip.
  intros padded_key_len padded_key_len_byte padded_keys_eq msgs_eq ops_eq ips_eq.
  intros HMAC_abstract HMAC_concrete.

  intros.
  unfold p, c in *.
  simpl in *.

  rewrite <- HMAC_abstract. rewrite <- HMAC_concrete.

  unfold HMAC. unfold HMAC_SHA256.HMAC. unfold HMAC_SHA256.OUTER. unfold HMAC_SHA256.INNER.
  unfold HMAC_SHA256.outerArg. unfold HMAC_SHA256.innerArg.

  unfold HMAC_2K. unfold GHMAC_2K. rewrite -> split_append_id.

  simpl.

  (* Major lemmas *)
  Check SHA_equiv_pad.
  apply SHA_equiv_pad.
  Check concat_equiv.
  apply concat_equiv.
  SearchAbout bytes_bits_lists.
  apply xor_equiv_Z; try assumption.

  *
    apply SHA_equiv_pad.
    apply concat_equiv.

  - apply xor_equiv_Z; try assumption.
  - assumption.
    (* xors preserve length *)
    *
      unfold b in *. simpl. unfold BLxor. rewrite -> list_length_map.
      rewrite -> combine_length.
      pose proof bytes_bits_length op (HMAC_SHA256.sixtyfour OP) as ops_len.
      rewrite -> ops_len.
      pose proof bytes_bits_length k K as keys_len.
      rewrite -> keys_len.
      rewrite -> padded_key_len.
      unfold HMAC_SHA256.sixtyfour.
      rewrite -> length_list_repeat.
      reflexivity.
      apply padded_keys_eq.
      apply ops_eq.

    *
      unfold b in *. simpl. unfold BLxor. rewrite -> list_length_map.
      rewrite -> combine_length.
      pose proof bytes_bits_length ip (HMAC_SHA256.sixtyfour IP) as ips_len.
      rewrite -> ips_len.
      pose proof bytes_bits_length k K as keys_len.
      rewrite -> keys_len.
      rewrite -> padded_key_len.
      unfold HMAC_SHA256.sixtyfour.
      rewrite -> length_list_repeat.
      reflexivity.
      apply padded_keys_eq.
      apply ips_eq.
Qed.

End HMAC_Pad.                   (* TODO move this End + rename and recompile things *)


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Blech.Reflect.

Import CategoryNotations.
Import BishopNotations.

Open Scope morphism_scope.
Open Scope bishop_scope.

Reserved Notation "C 'ᵒᵖ'" (at level 1).

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Op (K: Category): Category := {|
  Obj := K ;
  Mor A B := K B A ;

  id A := @id K A ;
  compose A B C f g := g ∘ f ;

  compose_id_left _ _ := @compose_id_right K _ _ ;
  compose_id_right _ _ := @compose_id_left K _ _ ;
  compose_compat _ _ _ _ _ p _ _ q := compose_compat _ _ q _ _ p ;
|}.

Module OpNotations.
  Notation "C 'ᵒᵖ'" := (Op C) : category_scope.
End OpNotations.