From Coq.Unicode Require Import Utf8.
From Coq.Program Require Import Tactics.
From Categories.Essentials Require Import Notations Facts_Tactics Quotient.
From Coq.Logic Require Import PropExtensionality.
From Categories Require Import
     Category.Main Functor.Main Adjunction.Main NatTrans.Main.
From Coq.Classes Require Import RelationClasses.
From cat_monotone Require Import PreOrder.

Record PO := {
  PO_type :> Type;
  PO_car :> PO_type → PO_type → Prop;
  PO_PO : PreOrder PO_car;
  PO_antisymm : ∀ x y, PO_car x y → PO_car y x → x = y }.

Existing Instance PO_PO.

Record PO_morphism (po po' : PO) := {
  POM_mor :> po → po';
  POM_mono x y : po x y → po' (POM_mor x) (POM_mor y) }.

Arguments POM_mor {_ _} _ _.

Lemma POM_morphism_eq (po po' : PO) (f g : PO_morphism po po') :
  (∀ x, f x = g x) → f = g.
Proof.
  intros Hfg.
  assert (POM_mor f = POM_mor g) by (FunExt; auto).
  destruct f as [f Hfmono]; destruct g as [g Hgmono];
    cbn in *; subst.
  PIR; trivial.
Qed.

Program Definition POM_id (po : PO) : PO_morphism po po :=
  {| POM_mor x := x |}.

Program Definition POM_comp (po po' po'' : PO)
  (f : PO_morphism po po') (g : PO_morphism po' po'') : PO_morphism po po'' :=
  {| POM_mor x := g (f x) |}.
Next Obligation.
Proof.
  repeat apply POM_mono; trivial.
Qed.

Program Definition PO_cat : Category :=
  {| Obj := PO;
    Hom := PO_morphism;
    compose := POM_comp;
    id := POM_id |}.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.
Next Obligation.
Proof.
  apply POM_morphism_eq; cbn; trivial.
Qed.

(** partial order to preorder *)
Definition preorder_of_partial_order (po : PO) : PreOrd :=
{| PRO_type := po; PRO_car := po |}.

Program Definition preorder_of_partial_order_morphism (po po' : PO)
           (f : PO_morphism po po')
  : PRO_morphism (preorder_of_partial_order po) (preorder_of_partial_order po') :=
{| PROM_mor := f; PROM_mono := POM_mono _ _ f |}.

Program Definition preorder_of_partial_order_func : Functor PO_cat PreOrd_cat :=
{| FO := preorder_of_partial_order; FA := preorder_of_partial_order_morphism |}.

Next Obligation.
Proof. apply PROM_morphism_eq; simpl; trivial. Qed.

(** preorder to partial order *)

Definition antisymm_rel_base (pro : PreOrd) (x y : pro) : Prop :=
  pro x y ∧ pro y x.

Program Definition antisymm_rel (pro : PreOrd) : EquiRel pro :=
  {| EQR_rel := antisymm_rel_base pro |}.
Next Obligation.
Proof.
  unfold antisymm_rel_base.
  split.
  - intros ?; split; reflexivity.
  - intros ???; tauto.
  - intros ??? [? ?] [? ?]; split; etransitivity; eauto.
Qed.

Definition partial_order_of_preorder_relation
  (pro : PreOrd) (x y : quotient (antisymm_rel pro)) : Prop :=
  pro (representative x) (representative y).

Lemma partial_order_of_preorder_relation_refl pro x :
  partial_order_of_preorder_relation pro x x.
Proof. unfold partial_order_of_preorder_relation; reflexivity. Qed.

Lemma partial_order_of_preorder_relation_trans pro x y z :
  partial_order_of_preorder_relation pro x y →
  partial_order_of_preorder_relation pro y z →
  partial_order_of_preorder_relation pro x z.
Proof. unfold partial_order_of_preorder_relation; etransitivity; eauto. Qed.

Lemma partial_order_of_preorder_relation_antisymm pro x y :
  partial_order_of_preorder_relation pro x y →
  partial_order_of_preorder_relation pro y x →
  x = y.
Proof.
  unfold partial_order_of_preorder_relation.
  intros Hxy Hyx.
  apply (uniquely_represented _ _ _ (representative x) (representative y));
  [apply representative_represented; fail|
   apply representative_represented; fail|].
  split; trivial.
 Qed.

Instance: ∀ pro, PreOrder (partial_order_of_preorder_relation pro).
Proof.
  intros; split.
  - intros ?; apply partial_order_of_preorder_relation_refl.
  - intros ???; apply partial_order_of_preorder_relation_trans.
Qed.

Program Definition partial_order_of_preorder (pro : PreOrd) : PO :=
{| PO_type := quotient (antisymm_rel pro);
   PO_car := partial_order_of_preorder_relation pro;
   PO_antisymm := partial_order_of_preorder_relation_antisymm pro|}.

Local Obligation Tactic := idtac.

Program Definition partial_order_of_preorder_morphism (pro pro' : PreOrd)
           (f : PRO_morphism pro pro')
  : PO_morphism (partial_order_of_preorder pro) (partial_order_of_preorder pro')
  := {| POM_mor := λ x, class_of (antisymm_rel pro') (f (representative x))|}.

Next Obligation.
Proof.
  intros pro pro' f x y Hxy; simpl in *.
  unfold partial_order_of_preorder_relation in *.
  etransitivity;
    [apply (representative_of_class_of
              (antisymm_rel pro') (f (representative x)))|].
  etransitivity;
    [|apply (representative_of_class_of
              (antisymm_rel pro') (f (representative y)))].
  apply (PROM_mono _ _ f); trivial.
Qed.

Program Definition partial_order_of_preorder_func : Functor PreOrd_cat PO_cat :=
{| FO := partial_order_of_preorder; FA := partial_order_of_preorder_morphism |}.

Next Obligation.
Proof.
  intros x.
  apply POM_morphism_eq; simpl; intros ?.
  apply class_of_representative.
Qed.
Next Obligation.
Proof.
  intros pro pro' por'' f g.
  apply POM_morphism_eq; simpl; intros ?.
  apply class_of_inj; split.
  - apply (PROM_mono _ _ g).
    etransitivity;
      [|apply (representative_of_class_of
                 (antisymm_rel pro') (f (representative x)))].
    reflexivity.
  - apply (PROM_mono _ _ g).
    etransitivity;
      [apply (representative_of_class_of
                 (antisymm_rel pro') (f (representative x)))|].
    reflexivity.
Qed.

(** properties of inclusion functor and back *)

Lemma preorder_of_partial_order_func_full :
  Full_Func preorder_of_partial_order_func.
Proof.
  intros po po' f; simpl in *.
  exists ({| POM_mor := f; POM_mono := (PROM_mono _ _ f) |}).
  apply PROM_morphism_eq; trivial.
Qed.

Lemma preorder_of_partial_order_func_faithful :
  Faithful_Func preorder_of_partial_order_func.
Proof.
  intros po po' f g Hfg; simpl in *.
  apply POM_morphism_eq.
  intros x.
  apply (equal_f (f_equal PROM_mor Hfg) x).
Qed.

Program Definition preorder_partial_order_adj_unit_map (pro : PreOrd) :
  PRO_morphism pro (preorder_of_partial_order (partial_order_of_preorder pro)) :=
{| PROM_mor := λ x, class_of (antisymm_rel pro) x  |}.

Next Obligation.
Proof.
  intros pro x y Hxy; simpl.
  unfold partial_order_of_preorder_relation.
  etransitivity;
      [apply (representative_of_class_of (antisymm_rel pro) x)|].
  etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) y)].
  trivial.
Qed.

Program Definition preorder_partial_order_adj_unit :
  NatTrans (Functor_id PreOrd_cat)
           (preorder_of_partial_order_func ∘ partial_order_of_preorder_func) :=
{| Trans := preorder_partial_order_adj_unit_map |}.

Next Obligation.
Proof.
  intros pro pro' f; simpl in *.
  apply PROM_morphism_eq; intros x; simpl.
  apply class_of_inj; split; apply (PROM_mono _ _ f).
  - etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) x)]; reflexivity.
  - etransitivity;
    [apply (representative_of_class_of (antisymm_rel pro) x)|]; reflexivity.
Qed.

Next Obligation.
Proof.
  intros pro pro' f; simpl in *.
  apply PROM_morphism_eq; intros x; simpl.
  apply class_of_inj; split; apply (PROM_mono _ _ f).
  - etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) x)]; reflexivity.
  - etransitivity;
    [apply (representative_of_class_of (antisymm_rel pro) x)|]; reflexivity.
Qed.

Program Definition preorder_partial_order_adj_morph_ex (pro : PreOrd) (po : PO)
        ( f : PRO_morphism pro (preorder_of_partial_order po)) :
  PO_morphism (partial_order_of_preorder pro) po :=
{| POM_mor := λ x, f (representative x) |}.

Next Obligation.
Proof.
  intros pro po f x y Hxy; simpl in *.
  apply (PROM_mono _ _ f); trivial.
Qed.

Program Definition preorder_partial_order_adj :
  (partial_order_of_preorder_func ⊣ preorder_of_partial_order_func)%functor :=
{| adj_unit := preorder_partial_order_adj_unit;
   adj_morph_ex := preorder_partial_order_adj_morph_ex |}.

Next Obligation.
Proof.
  intros pro po f; simpl in *.
  apply PROM_morphism_eq; simpl in *.
  intros x.
  apply PO_antisymm.
  - apply (PROM_mono _ _ f).
    etransitivity;
    [|apply (representative_of_class_of (antisymm_rel pro) x)]; reflexivity.
  - apply (PROM_mono _ _ f).
    etransitivity;
    [apply (representative_of_class_of (antisymm_rel pro) x)|]; reflexivity.
Qed.
Next Obligation.
Proof.
  intros pro po f g h Hfg Hfh; simpl in *.
  pose proof (equal_f (f_equal PROM_mor Hfg)) as Hfg'; simpl in *.
  pose proof (equal_f (f_equal PROM_mor Hfh)) as Hfh'; simpl in *.
  apply POM_morphism_eq; intros x; simpl in *.
  specialize (Hfg' (representative x)).
  specialize (Hfh' (representative x)).
  rewrite class_of_representative in Hfg', Hfh'.
  rewrite <- Hfg', <- Hfh'; trivial.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Theory.Natural.Transformation.
Require Import Category.Functor.Bifunctor.
Require Import Category.Functor.Strong.
Require Import Category.Functor.Applicative.
Require Import Category.Functor.Structure.Monoidal.
Require Import Category.Functor.Structure.Monoidal.Id.
Require Import Category.Functor.Structure.Monoidal.Compose.
Require Import Category.Functor.Structure.Monoidal.Pure.
Require Import Category.Natural.Transformation.Monoidal.
Require Import Category.Natural.Transformation.Applicative.
Require Import Category.Natural.Transformation.Strong.
Require Import Category.Structure.Monoidal.Closed.
Require Import Category.Structure.Monoidal.Internal.Product.
Require Import Category.Functor.Applicative.

Generalizable All Variables.

Section Traversable.

Context {C : Category}.
Context `{@ClosedMonoidal C}.
Context {F : C ⟶ C}.

#[local] Obligation Tactic := idtac.

Program Instance Id_Applicative : @Applicative C _ (Id[C]) := {
  applicative_is_strong := Id_StrongFunctor;
  applicative_is_lax_monoidal := Id_LaxMonoidalFunctor
}.

Program Instance Compose_Applicative
  `{@Applicative C _ G}
  `{@Applicative C _ K} :
  @Applicative C _ (Compose G K) := {
  applicative_is_strong := Compose_StrongFunctor G K _ _;
  applicative_is_lax_monoidal := Compose_LaxMonoidalFunctor _ _
}.

Class Traversable := {
  sequence {G : C ⟶ C} `{@Applicative C _ G} : F ◯ G ⟹ G ◯ F;

  sequence_naturality {G : C ⟶ C} `{@Applicative C _ G}
                      {H : C ⟶ C} `{@Applicative C _ H} (N : G ⟹ H)
                      (f : @Applicative_Transform C _ _ _ _ _ N) {X} :
    transform[N] (F X) ∘ transform[@sequence G _] X
      ≈ transform[@sequence H _] X ∘ fmap[F] (transform[N] _);

  sequence_Id {X} : transform[@sequence Id _] X ≈ id;
  sequence_Compose {G : C ⟶ C} `{@Applicative C _ G}
                   {H : C ⟶ C} `{@Applicative C _ H} {X} :
    transform[@sequence (Compose G H) _] X
      ≈ fmap[G] (transform[sequence] X) ∘ transform[sequence] _
}.

End Traversable.

Arguments Traversable {_ _} F.

#[export]
Program Instance Id_Traversable `{@ClosedMonoidal C} (x : C) :
  Traversable (@Id C) := {
  sequence := fun _ _ => {| transform := fun _ => id |}
}.

Require Import Category.Functor.Diagonal.

#[export]
Program Instance Diagonal_Traversable
  {C J : Category} `{@ClosedMonoidal C} (x : C) :
  Traversable (Diagonal C x) := {
  sequence := fun G _ => {| transform := fun _ => pure[G] |}
}.
Next Obligation.
  unfold pure.
  simpl; normal.
  rewrite <- !comp_assoc.
  normal.
  rewrite <- naturality.
  rewrite <- !comp_assoc.
  apply compose_respects; [reflexivity|].
  rewrite !comp_assoc.
  apply compose_respects; [|reflexivity].
  rewrite (lax_pure_transform[N]).
  rewrite <- strength_transform; simpl.
  rewrite <- !comp_assoc; cat.
  apply compose_respects; [reflexivity|].
  now rewrite bimap_comp_id_left.
Qed.
Next Obligation.
  unfold pure, bimap; simpl; cat.
  apply iso_to_from.
Qed.
Next Obligation.
  unfold pure; simpl.
  normal.
  rewrite <- !comp_assoc.
  rewrite !fmap_comp.
  rewrite <- !comp_assoc.
  apply compose_respects; [reflexivity|].
  rewrite !comp_assoc.
  apply compose_respects; [|reflexivity].
  rewrite <- !comp_assoc.
  apply compose_respects; [reflexivity|].
  rewrite !comp_assoc.
  rewrite <- !fmap_comp.
  rewrite <- !comp_assoc; cat.
  rewrite iso_from_to, id_right.
  rewrite bimap_comp_id_left.
  rewrite !comp_assoc.
  comp_right.
  symmetry.
  spose (@strength_natural _ _ G _ x _ id _ _ lax_pure) as X0.
  rewrite bimap_id_id in X0.
  rewrite fmap_id in X0.
  rewrite id_right in X0.
  rewrite X0.
  cat.
Qed.


(****************************************************************************)
(* Copyright 2020 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Coq.Vectors.Vector.
Require Import Cava.Arrow.ArrowExport.
Require Import Cava.Arrow.CombinatorProperties.
Require Import Cava.BitArithmetic.
Require Import Cava.NatUtils.
Require Import Cava.ListUtils.
Require Import Cava.Tactics.
Require Import Cava.VectorUtils.
Require Import AesSpec.Cipher.
Require Import AesSpec.CipherProperties.
Require Import AesSpec.ExpandAllKeys.
Require Import AesSpec.InterleavedCipher.
Require Import Aes.CipherEquivalenceCommon
     Aes.OpenTitanCipherProperties Aes.CipherRoundProperties
     Aes.UnrolledOpenTitanCipher.
Import VectorNotations ListNotations.
Import CipherEquivalenceCommon.Notations.

Section Equivalence.
  Context (sbox : Pkg.SboxImpl)
          (aes_key_expand_spec :
             Pkg.SboxImpl -> bool -> Vector.t bool 4 ->
             rconst -> keypair -> rconst * keypair)
          (aes_key_expand_correct :
             forall sbox_impl op_i round_id rcon key_i,
               kinterp (aes_key_expand sbox_impl)
                       (op_i, (round_id, (rcon, (key_i, tt))))
               = aes_key_expand_spec sbox_impl op_i round_id rcon key_i)
          (aes_sub_bytes_correct :
             forall sbox_impl op_i state,
               kinterp (SubBytes.aes_sub_bytes sbox_impl) (op_i, (state, tt))
               = aes_sub_bytes_spec sbox_impl op_i state)
          (aes_shift_rows_correct :
             forall op_i state,
               kinterp ShiftRows.aes_shift_rows (op_i, (state, tt))
               = aes_shift_rows_spec op_i state)
           (aes_mix_columns_correct :
             forall op_i state,
               kinterp MixColumns.aes_mix_columns (op_i, (state, tt))
               = aes_mix_columns_spec op_i state).

  Definition add_round_key : state -> key -> state :=
    @bitwise (Vector (Vector (Vector Bit 8) 4) 4) (fun a b => xorb a b).
  Definition sub_bytes : state -> state := aes_sub_bytes_spec sbox false.
  Definition shift_rows : state -> state := aes_shift_rows_spec false.
  Definition mix_columns : state -> state := aes_mix_columns_spec false.

  Definition key_expand : nat -> rconst * keypair -> rconst * keypair :=
    fun i rk => aes_key_expand_spec sbox false (nat_to_bitvec _ i) (fst rk) (snd rk).

  Lemma unrolled_cipher_spec_equiv
        init_keypair first_key last_key middle_keys input :
    let Nr := 14 in
    let init_rcon := nat_to_byte 1 in
    (* reverse initial keypair (which is round key 0 ++ round key 1)
       so that the first round key (0) is in second position *)
    let init_keypair_rev := swap_keys init_keypair in
    (* key_expand state is rconst * keypair *)
    let init_rk := (init_rcon, init_keypair_rev) in
    let all_rcons_and_keypairs := all_keys key_expand Nr init_rk in
    (* representation change: project out the round (second) key and transpose it *)
    let all_keys := List.map (fun x : rconst * keypair =>
                                transpose_rev (sndkey (snd x)))
                             all_rcons_and_keypairs in
    all_keys = (first_key :: middle_keys ++ [last_key])%list ->
    unrolled_cipher_spec aes_key_expand_spec sbox false input init_keypair
    = cipher state key add_round_key sub_bytes shift_rows mix_columns
             first_key last_key middle_keys input.
  Proof.
    cbv zeta. cbn [denote_kind] in *. intro Hall_keys.

    (* Get all states from key expansion *)
    map_inversion Hall_keys; subst.
    match goal with H : @eq (list (_ * keypair)) _ (_ :: _ ++ [_])%list |- _ =>
                    rename H into Hall_keys end.

    (* representation change; use full key-expansion state (rconst * keypair) *)
    erewrite cipher_change_key_rep with
        (projkey := fun x => transpose_rev (sndkey (snd x)))
      by reflexivity.

    erewrite <-cipher_interleaved_equiv by eassumption.
    cbv [unrolled_cipher_spec final_cipher_round_spec
                              cipher_interleaved cipher_round_interleaved].
    repeat destruct_pair_let.
    rewrite denote_kind_eqb_refl. cbn [mux].
    rewrite fold_left_fst_unchanged by auto.
    autorewrite with push_to_list.
    rewrite fold_left_map. cbn [fst snd].
    match goal with
    | |- ?LHS = ?RHS =>
      match LHS with
      | context [ @List.fold_left (?A1 * (?A2 * ?A3)) ?B1 ?f1 ?ls1 ?b1 ] =>
        match RHS with
        | context [ @List.fold_left (A1 * A3 * A2) ?B2 ?f2 ?ls2 ?b2 ] =>
          change ls1 with ls2;
            rewrite (fold_left_preserves_relation_seq
                       (fun _ x y => x = (fst (fst y), (snd y, snd (fst y))))
                       f1 f2 _ _ b1 b2)
        end
      end
    end; [ | | ].
    { (* equivalence post-loop *)
      reflexivity. }
    { (* equivalence at start of loop *)
      reflexivity. }
    { (* equivalence holds through loop body *)
      intros; subst. cbv [key_expand_and_round_spec].
      repeat destruct_pair_let; cbn [fst snd].
      rewrite denote_kind_eqb_refl. cbn [mux].
      fold fstkey sndkey. repeat (f_equal; [ ]).
      rewrite denote_kind_eqb_N2Bv_sized by (apply N.size_nat_le; cbn; Lia.lia).
      cbv [mux]. change 0%N with (N.of_nat 0).
      rewrite N.eqb_compare, N2Nat.inj_compare, !Nat2N.id, <-Nat.eqb_compare.
      reflexivity. }
  Qed.
End Equivalence.


(** * Formalization of CPS-Conversion *)

(** We'll start out by defining the syntax of a direct-style program,
followed by defining what evaluating said program means. Once we've
done that, we'll define a CPS-conversion function, and then prove that
the resulting expression is equivalent to the original. *)

From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.

(* This "CpsFormalization" comes from the _CoqProject file *)
From CpsFormalization Require Import Env.

(* ################################################################# *)
(** * Syntax Definition *)

(** We're going to be modeling an untyped lambda calculus for
    simplicity's stake. What follows below are the formal
    definitions of the syntax. *)

(* Primitive binary operators *)
Inductive prim_binop : Type :=
  | PrimPlus
  | PrimMinus
  | PrimMult
  | PrimEq.

Inductive sexpr : Type :=
  | SId (x : string)
  | SNum (n : nat)
  (* TODO: include a closure case maybe *)
  | SLambda (args : list string) (body : sexpr)
  (* I'd like to add a constraint that fexpr reduces to an instance of SLambda. *)
  | SApp (fexpr : sexpr) (args : list sexpr)
  (* Might be nice to constrain the set of strings *)
  | SPrimBinary (op : prim_binop) (a1 a2 : sexpr)
  | SIf (cond : sexpr) (tcase : sexpr) (fcase : sexpr).

Definition environment := total_map sexpr.

(** ** Notations *)

(** Now we'll define some convenience notations so we don't have to
    write awkward Coq and can write something a little closer to the
    Lisp we all know and love. *)

Coercion SId : string >-> sexpr.
Coercion SNum : nat >-> sexpr.
(* TODO: fill in here *)

(* ================================================================= *)
(** * Evaluation *)

(** Let's write a little interpreter for our language. *)

Fixpoint zip_map {X Y Z : Type} (f : X -> Y -> Z) (l1 : list X) (l2 : list Y) : list Z :=
  match l1, l2 with
  | nil, _ => nil
  | _, nil => nil
  | x :: xs, y :: ys => (f x y) :: (zip_map f xs ys)
  end.

Fixpoint extend_env (env : environment) (params : list string) (args : list sexpr) : environment :=
  match params, args with
  | nil, _ => env
  | _, nil => env
  | x :: rest_params, arg :: rest_args => (x !-> arg ; (extend_env env rest_params rest_args))
  end.

(* Consider defining this as a relation so I can model a partial function; alternatively, instead of returning sexpr; return sexpr + error *)
Fixpoint seval (env : environment) (expr : sexpr) : sexpr :=
  match expr with
  | SId x => env x
  | SNum n => SNum n
  | SLambda args body => SLambda args body
  (* Now the fun begins *)
  | SApp func args =>
    (* TODO: evaluate the function *)
    (* evaulate the arguments *)
    let xs := map (seval env) args in
    seval (extend_env env )

  | SPrimBinary op a1 a2 => SNum 42
  | SIf cond tcase fcase => SNum 42
  end.

Definition empty_env := t_empty (SId "null").
Check (seval empty_env).


(**
This just transforms "pretty print" notation to internal
de Bruijn indices. It's probably the most involved code
that has the least to do with the actual type theoretic
machinery.
*)
Require Import String.
Require Export Coq.Lists.List.
Require Export Coq.Arith.Compare_dec.
Require Export Coq.Arith.EqNat.
Require Export Util.
Require Import Expression.

(**
For denaming some pretty-printed lambda expression into our
internal representation.
*)
Module PrettyTerm.
Inductive pterm : Type :=
 | tau : pterm
 | Var : string -> pterm
 | Lam : string -> pterm -> pterm -> pterm
 | App : pterm -> pterm -> pterm.

(** The free variables in a given [pterm]. *)
Fixpoint FV (t:pterm): list string :=
  match t with
  | tau => nil
  | Var s => s::nil
  | Lam x t b => rm x (append (FV t) (FV b))
  | App t1 t2 => append (FV t1) (FV t2)
  end.

(** A [context] for pretty print reasons is a list of
declarations, which themselves are ordered pairs of a
[string] identifier, and its corresponding [pterm] "type".
*)
Definition context := list (string * pterm).
End PrettyTerm.

Notation "` x" := (if string_dec x "tau"
                   then PrettyTerm.tau
                   else PrettyTerm.Var x) (at level 20).
Notation "\ x t ~> M" := (PrettyTerm.Lam x t M) (at level 30).
Infix "$" := PrettyTerm.App (at level 25, left associativity).

(* Unit tests for [FV] *)
Example FV_ex1 :
  PrettyTerm.FV (`"f" $ `"g" $ `"h" $ `"i") =
  "f"%string :: "g"%string :: "h"%string :: "i"%string :: nil.
Proof. reflexivity. Qed.

Example prettier_left_assoc_ex1 :
  `"f" $ `"g" $ `"h" $ `"i" =
  PrettyTerm.App
    (PrettyTerm.App
       (PrettyTerm.App (PrettyTerm.Var "f") (PrettyTerm.Var "g"))
       (PrettyTerm.Var "h")) (PrettyTerm.Var "i").
Proof.
  simpl. reflexivity.
Qed.

Example prettier_ex2 :
  \ "f" `"tau" ~> `"f" $ (\ "x" `"tau" ~> `"x" $ `"y") =
  PrettyTerm.Lam "f" PrettyTerm.tau
    (PrettyTerm.App (PrettyTerm.Var "f")
       (PrettyTerm.Lam "x" PrettyTerm.tau
          (PrettyTerm.App (PrettyTerm.Var "x") (PrettyTerm.Var "y")))).
Proof. simpl. reflexivity. Qed.

Fixpoint lookup (s : string) (ls : list (string * nat)):
option nat :=
  match ls with
  | nil => None
  | (x, n) :: t => if string_dec x s then Some n else lookup s t
  end.

(** Pushes the depth one layer, introduces a "new" variable [s]. *)
Fixpoint hide (s : string) (ls : list (string * nat)):
list (string * nat) :=
  match ls with
  | nil => (s, 0) :: nil
  | (x, n) :: t =>
      if string_dec x s then (x, 0) :: hide s t else (x, n + 1) :: hide s t
  end.

Fixpoint dename' (t : PrettyTerm.pterm) (binds : list (string * nat)): exp :=
  match t with
  | PrettyTerm.tau => tau
  | PrettyTerm.Var s =>
      match lookup s binds with
      | Some n => EVar n
      | None => EVar 0
      end
  | PrettyTerm.Lam s t b =>
      ELam (dename' t (hide s binds)) (dename' b (hide s binds))
  | PrettyTerm.App t1 t2 => EApp (dename' t1 binds) (dename' t2 binds)
  end.

(** Given a list [identifiers] of free variables, and a list [binds] of
    binds to de Bruijn indices, update it adding values for the free variables. *)
Fixpoint FV_binds (identifiers : list string) (binds : list (string * nat)):
list (string * nat) :=
  match identifiers with
  | nil => binds
  | x :: tl =>
      match lookup x binds with
      | Some n => FV_binds tl binds
      | None => FV_binds tl (cons (x, length binds) binds)
      end
  end.

Fixpoint context_binds' (Gamma : PrettyTerm.context)
(binds : list (string * nat)): list (string * nat) :=
  match Gamma with
  | nil => binds
  | (x, _) :: tl =>
      match lookup x binds with
      | Some n => context_binds' tl binds
      | None => context_binds' tl (cons (x, length binds) binds)
      end
  end.

(** Given a [context Gamma = (xN,type_N), ..., (x1, type_1)] produce a lookup
    map for the variables and identifiers to convert to de Bruijn indices. *)
Definition context_binds (Gamma : PrettyTerm.context) :
  list (string * nat) := context_binds' (rev Gamma) nil.

(* Unit tests for the [context_binds] *)
Open Scope string_scope.
Example context_binds_ex1 :
  context_binds (cons ("f", PrettyTerm.tau) nil) = ("f", 0) :: nil.
Proof.
  reflexivity.
Qed.

Example context_binds_ex2 :
  context_binds
    (cons ("f", PrettyTerm.tau)
       (cons ("g", PrettyTerm.tau) (cons ("f", PrettyTerm.tau) nil))) =
  ("g", 1) :: ("f", 0) :: nil.
Proof.
  reflexivity.
Qed.

Example fv_binds_context_binds_ex1 :
  FV_binds (PrettyTerm.FV (`"f" $ `"g" $ `"f"))
    (context_binds (cons ("g", PrettyTerm.tau) nil)) =
  ("f", 1) :: ("g", 0) :: nil.
Proof.
  reflexivity.
Qed.
Close Scope string_scope.

(** Given a [PrettyTerm.pterm] without a [context], convert it
    into a [exp] using de Bruijn indices. *)
Definition dename (t : PrettyTerm.pterm) : exp :=
  dename' t (FV_binds (PrettyTerm.FV t) nil).

(** If we have a given [context Gamma], then we want to convert it into
    a [list exp] which binds to de Bruijn indices. *)
Fixpoint deconstruct_context (c : PrettyTerm.context)
(binds : list (string * nat)): list exp :=
  match c with
  | nil => nil
  | (x, t) :: ctxt => cons (dename' t binds) (deconstruct_context ctxt binds)
  end.

(** Claim: Let [c = f : tau, h : \g:tau~>f], then
    [deconstruct_context c (context_binds c) = Elam tau f :: tau].
*)
Example deconstruct_context_ex1 :
  let c :=
    snoc ("f"%string, `"tau") (cons ("h"%string, \ "g" `"tau" ~> `"f") nil) in
  deconstruct_context c (context_binds c) = ELam tau (EVar 1) :: tau :: nil.
Proof. reflexivity. Qed.

(** Claim: Let [c = h : \g:tau~>f, g : tau, f : tau], then
    [deconstruct_context c (context_binds c) = Elam tau f :: tau :: tau].
*)
Example deconstruct_context_ex2 :
  let c :=
    snoc ("f"%string, `"tau")
      (snoc ("g"%string, `"tau") (cons ("h"%string, \ "x" `"g" ~> `"f") nil)) in
  deconstruct_context c (context_binds c) =
  ELam (EVar 2) (EVar 1) :: tau :: tau :: nil.
Proof. reflexivity. Qed.

(** Convert a [PrettyTerm.pterm] in a given [PrettyTerm.context] to
    a pair [context, exp] using de Bruijn indices. Free Variables are
    handled properly.
*)
Definition dename_with_context (c : PrettyTerm.context)
  (t : PrettyTerm.pterm) : context * exp :=
  let binds := FV_binds (PrettyTerm.FV t) (context_binds c) in
  (deconstruct_context c binds, dename' t binds).

(* Unit tests for [dename_with_context] *)
Open Scope string_scope.
Example dename_with_context_ex1 :
  dename_with_context (cons ("g", PrettyTerm.tau) nil) (`"f" $ `"g" $ `"f") =
  (tau :: nil, EApp (EApp (EVar 1) (EVar 0)) (EVar 1)).
Proof.
  reflexivity.
Qed.

Example dename_ex1 :
  dename (`"f" $ `"g" $ `"f") = EApp (EApp (EVar 0) (EVar 1)) (EVar 0).
Proof.
  reflexivity.
Qed.
Close Scope string_scope.


(** * Profunctors *)
Require Import Category.Core Functor.Core Category.Prod Category.Dual SetCategory.Core.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Declare Scope profunctor_scope.
Delimit Scope profunctor_scope with profunctor.

Section profunctor.
  (** Quoting nCatLab:

      If [C] and [D] are categories, a profunctor from [C] to [D] is a functor [Dᵒᵖ * C -> Set]. Such a profunctor is usually written as [F : C ⇸ D].

      Every functor [f : C -> D] induces two profunctors [D(1, f) : C ⇸ D] and [D(f, 1) : D ⇸ C], defined by [D(1,f)(d,c) = D(d, f(c))] and [D(f, 1)(c,d) = D(f(c), d)]. These profunctors are called representable (or sometimes one of them is corepresentable).

      In particular the identity profunctor [Id : C ⇸ C] is represented by the identity functor and hence is given by the hom-functor [C(−, −) : Cᵒᵖ * C -> Set].

      The notion generalizes to many other kinds of categories. For instance, if [C] and [D] are enriched over some symmetric closed monoidal category [V], then a profunctor from [C] to [D] is a [V]-functor [Dᵒᵖ ⊗ C -> V]. If they are internal categories, then a profunctor [C ⇸ D] is an internal diagram on [Dᵒᵖ * C], and so on. There are also other equivalent definitions in each case; see below.

      A profunctor is also sometimes called a (bi)module or a distributor or a correspondence, though the latter word is also used for a span. The term “module” tends to be common in Australia, especially in the enriched case; here the intuition is that for one-object [V]-categories, i.e. monoids in [V], profunctors really are the same as bimodules between such monoids in the usual sense. “Profunctor” is perhaps more common in the Set-based and internal cases (but is also used in the enriched case); here the intuition is that a profunctor is a generalization of a functor, via the construction of “representable” profunctors. Jean Bénabou, who invented the term and originally used “profunctor,” now prefers “distributor,” which is supposed to carry the intuition that a distributor generalizes a functor in a similar way to how a distribution generalizes a function.

      Note that the convention that a profunctor is a functor [Dᵒᵖ * C -> Set] is not universal; some authors reverse C and D and/or put the “op” on the other one. See the discussion below. *)

  Context `{Funext}.
  Variables C D : PreCategory.

  (** We capitalize [Profunctor] just like we capitalize [Functor]. *)
  Definition Profunctor := Functor (D^op * C) set_cat.
End profunctor.

Bind Scope profunctor_scope with Profunctor.

Module Export ProfunctorCoreNotations.
  Notation "x -|-> y" := (Profunctor x y) : type_scope.
End ProfunctorCoreNotations.


(**  ** Rules of the system

This file defines the rules of transition system specified in:

Joëlle Despeyroux, Amy Felty, Pietro Lio and Carlos Olarte: A Logical
Framework for Modelling Breast Cancer Progression

There are 177 rules that modify the state of the cell according to the driven
mutations it posses.
 *)

Require Export TSystem.Syntax.
Require Export FLL.SL.FLLTactics.
Require Export FLL.Misc.Permutations.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

Hint Constructors plusOne : core .
Hint Constructors uniform_atm'  : core.
Hint Constructors IsTerm : core .

(** Rules changing the state of the system:
1. Advancing the time in Dt units
2. Modifying the three parameters of the cell: location, fitness and list of mutations.
*)
  Definition EncodeRule (Dt loc fit listMut loc' fit' listMut': nat) (t n :uexp) : oo :=
    ( (perp  T{ t} ) ** perp C{n ; loc ; fit ; listMut}) ** ( (atom T{ t s+ (CN Dt)} $ (atom C{n ;loc' ; fit' ; listMut'}) )) .

  (** Rules for apoptosis *)
  Definition EncodeRuleAP (Dt loc fit listMut : nat) (t n : uexp): oo :=
    ( (perp  T{ t} ) ** perp C{n ; loc ; fit ; listMut }) ** ( (atom T{ t s+ (CN Dt)}) $ (atom A{ n })).

Hint Unfold EncodeRule : core  .
Hint Unfold EncodeRuleAP : core .

(* ================================================ *)
(** Definition of the rules *)
(* ================================================ *)
(**  In the breast: *)
Definition br0             := EncodeRule d00 breast 1 NONE breast 0 NONE .
Definition br1 (f:nat)     := EncodeRuleAP (d01 f) breast f NONE .
Definition br2             := EncodeRule d02 breast 1 NONE breast 1 TG .
Definition brt0            := EncodeRule d10 breast 1 TG breast 0 TG .
Definition brt0r            := EncodeRule d10r breast 1 TG breast 2 TG .
Definition brt1 (f:nat)    := EncodeRuleAP (d11 f) breast f TG .
Definition brt2 (f:nat)    := EncodeRule d12 breast f TG breast (f+1) EP .
Definition bre0 (f:nat)    := EncodeRule (d20 f) breast f EP breast (f-1) EP .
Definition bre0r (f:nat)    := EncodeRule (d20r f) breast f EP breast (f+1) EP .
Definition bre1 (f:nat)    := EncodeRuleAP (d21 f) breast f EP .
Definition bre2 (f:nat)    := EncodeRule (d22 f) breast f EP blood (f+1) EP .

(** In the blood: *)
Definition ble0 (f:nat)    := EncodeRule (d30 f) blood f EP blood (f-1) EP .
Definition ble0r (f:nat)   := EncodeRule (d30r f) blood f EP blood (f+1) EP .
Definition ble1 (f:nat)    := EncodeRuleAP (d31 f) blood f EP .
Definition ble2 (f:nat)    := EncodeRule (d32 f) blood f EP blood (f+2) EPCD .
Definition blec0 (f:nat)   := EncodeRule (d40 f) blood f EPCD blood (f-1) EPCD .
Definition blec1 (f:nat)   := EncodeRuleAP (d41 f) blood f EPCD .
Definition blec2 (f:nat)   := EncodeRule (d42 f) blood f EPCD blood (f+2) EPCDCD .
Definition blec3 (f:nat)   := EncodeRule (d43 f) blood f EPCD blood (f+2) EPCDME .
Definition blecc0 (f:nat)  := EncodeRule (d50 f) blood f EPCDCD blood (f-1) EPCDCD .
Definition blecc1 (f:nat)  := EncodeRuleAP (d51 f) blood f EPCDCD .
Definition blecc2 (f:nat)  := EncodeRule (d52 f) blood f EPCDCD blood (f+2) EPCDCDME .
Definition blecm0 (f:nat)  := EncodeRule (d60 f) blood f EPCDME blood (f-1) EPCDME .
Definition blecm1 (f:nat)  := EncodeRuleAP (d61 f) blood f EPCDME .
Definition blecm2 (f:nat)  := EncodeRule (d62 f) blood f EPCDME blood (f+2) EPCDCDME .
Definition bleccm0 (f:nat) := EncodeRule (d70 f) blood f EPCDCDME blood (f-1) EPCDCDME .
Definition bleccm1 (f:nat) := EncodeRuleAP (d71 f) blood f EPCDCDME .
Definition bleccm2 (f:nat) := EncodeRule (d72 f) blood f EPCDCDME bone (f+1) EPCDCDME .

(** In the bone: *)
Definition bo0 (f:nat)     := EncodeRule (d80 f) bone f EPCDCDME bone (f-1) EPCDCDME .
Definition bo1 (f:nat)     := EncodeRuleAP (d81 f) bone f EPCDCDME .
Definition bo2 (f:nat)     := EncodeRule (d82 f) bone f EPCDCDME bone (f+1) EPCDCDMEse .

(** Theory containing the whole set of rules *)

Definition GenRs (R : nat -> uexp -> uexp -> oo) (l: list nat) := map R l.

Definition Theory := [br0] ++ (GenRs br1 [0;1]) ++ [br2 ; brt0 ; brt0r] ++
                           (GenRs brt1 [0;1;2]) ++ (GenRs brt2 [1;2]) ++
                           (GenRs bre0 [1;2;3]) ++ (GenRs bre0r [1;2]) ++
                           (GenRs bre1 [0;1;2;3]) ++ (GenRs bre2 [1;2;3]) ++
                           (* blood *)
                           (GenRs ble0 [1;2;3;4]) ++ (GenRs ble0r [1;2;3]) ++
                           (GenRs ble1 [0;1;2;3;4]) ++
                           (GenRs ble2 [1;2;3;4]) ++ (GenRs blec0 [1;2;3;4;5;6]) ++
                           (GenRs blec1 [0;1;2;3;4;5;6]) ++ (GenRs blec2 [1;2;3;4;5;6]) ++
                           (GenRs blec3 [1;2;3;4;5;6]) ++ (GenRs blecc0 [1;2;3;4;5;6]) ++
                           (GenRs blecc1 [0;1;2;3;4;5;6;7;8]) ++
                           (GenRs blecc2 [1;2;3;4;5;6;7;8])  ++
                           (GenRs blecm0 [1;2;3;4;5;6;7;8]) ++
                           (GenRs blecm1 [0;1;2;3;4;5;6;7;8]) ++
                           (GenRs blecm2 [1;2;3;4;5;6;7;8]) ++
                           (GenRs bleccm0 [1;2;3;4;5;6;7;8;9;10]) ++
                           (GenRs bleccm1 [0;1;2;3;4;5;6;7;8;9;10]) ++
                           (GenRs bleccm2 [1;2;3;4;5;6;7;8;9;10]) ++
                           (* Bone *)
                           (GenRs bo0 [1;2;3;4;5;6;7;8;9;10;11]) ++
                           (GenRs bo1 [0;1;2;3;4;5;6;7;8;9;10;11]) ++
                           (GenRs bo2 [1;2;3;4;5;6;7;8;9;10;11]).

Inductive OLTheory : oo -> Prop :=
| oltheory : forall F t n, In F Theory -> IsTerm t -> IsTerm n ->  OLTheory (F t n)
.

Notation " n '|---' B ';' L ';' X " := (seqN OLTheory n B L X) (at level 80).
Notation " '|--' B ';' L ';' X " := (seq OLTheory  B L X) (at level 80).

(** Solves goals of the form [In F Theory] *)
Ltac SolveInTheory :=
  try
    match goal with
    | [|- OLTheory _] => constructor;auto; unfold Theory;
                         simpl;
                         repeat match goal with
                                | [|- ?F = ?F \/ ?G] => left;auto
                                | _ => right
                                end
    end.

Lemma tensorapp : forall B L1 L2 F G,
    |-- B ; L2 ; ( >> F) -> |-- B ; L1 ; ( >>  G) -> |-- B ; L1 ++ L2 ;  ( >>  F ** G) .
  intros.
  eapply tri_tensor' with (N:= L1) (M:=L2);solveF.
Qed.

Lemma tensorapp' : forall B L1 L2 F G,
    |-- B ; L1 ; ( >> F) -> |-- B ; L2 ; ( >>  G) -> |-- B ; L1 ++ L2 ;  ( >>  F ** G) .
  intros.
  eapply tri_tensor' with (N:= L2) (M:=L1);solveF.
Qed.

(** This tactic applies the rule R on the current goal. The splitting
of the context is made automatically due to the particular
representation of the state of the system we have here.  *)
Ltac applyRule R :=
  decide3 R;SolveInTheory;
  SplitContext' 1;
  apply tensorapp; [
    SplitContext' 1; apply tensorapp';solveLL| simpl];solveLL.

Ltac ApplyRule R :=
  match goal with
    [|- context[ T{ ?time}  ]  ] =>
    match goal with
      [|- context[ C{ ?n ; _ ; _ ; _ }]] =>
      applyRule (R time n)
    end
  end.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Essentials.HoTT_Facts.
Require Import Category.Main.
Require Import Functor.Functor.
Require Import Cat.Cat.
Require Import Coq_Cats.Type_Cat.Type_Cat.

(* empty and singleton categories *)

(** The empty category – initial object of Cat. *)
Definition EmptyCat : Category :=
  {|
    Obj := (Empty : Type);
    Hom := fun _ _ => (Unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => idpath;
    assoc_sym := fun _ _ _ _ _ _ _ => idpath;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    Hom_HSet := fun x _ => match x with end
  |}.

(** The singleton category – terminal object of Cat. *)
Program Definition SingletonCat : Category :=
  {|
    Obj := (Unit : Type);
    Hom := fun _ _ => (Unit : Type);
    compose := fun _ _ _ _ _ => tt;
    assoc := fun _ _ _ _ _ _ _ => idpath;
    assoc_sym := fun _ _ _ _ _ _ _ => idpath;
    id := fun _ => tt;
    id_unit_left :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    id_unit_right :=
      fun _ _ h =>
        match h as u return (tt = u) with
        | tt => idpath
        end;
    Hom_HSet := fun _ _ h h' => @trunc_contr _ _ (istrunc_trunctype_type HUnit h h')
  |}.

Notation "0" := (EmptyCat) : category_scope.
Notation "1" := (SingletonCat) : category_scope.

(* discrete categories in general *)
Section Discr.
  Context (obj : hSet).

  (** Discrete category – one in which has no arrow but identitities.
Note that this definition is not necessarily a discrete cat in Coq as UIP is not
generally provable. We simply assume so by implicitly assuming object type to have UIP.
In HoTT terms, we assume obj to be a HSet. *)
  Program Definition Discr_Cat : Category :=
    {|
      Obj := obj;
      Hom := fun a b => a = b;
      compose := @concat _;
      id := fun a => idpath
    |}.

End Discr.

(*
Definition Type_n (n : nat) : Type := {x : nat | Tle x n}.

Notation "'Discr_n' n" := (Discr_Cat (Type_n n)) (at level 200, n bigint) : category_scope.
*)

(*
(** Any discrete category is ismorphic to its dual. *)
Section Discr_Cat_Dual_Iso.
  Context (obj : Type).

  Local Hint Extern 1 => progress cbn.

  Program Definition Discr_Cat_Dual_Iso :
    (Discr_Cat obj ≃≃ (Discr_Cat obj)^op ::> Cat)%isomorphism%category
    :=
      {|
        iso_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|};
        inverse_morphism := {|FO := fun x => x; FA := fun _ _ h => eq_sym h|}
      |}.

End Discr_Cat_Dual_Iso.
 *)
(*
(** Any two isomorphic types form isomorphic discrete categories. *)
Section Discr_Cat_Iso.
  Context {obj obj' : Type} (I : (obj <~> obj' ::> Type_Cat)%isomorphism).

  Program Definition Discr_Cat_Iso :
    ((Discr_Cat obj) ≃≃ (Discr_Cat obj') ::> Cat)%isomorphism
    :=
      {|
        iso_morphism :=
          {|
            FO := iso_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (iso_morphism I c) = (iso_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |};
        inverse_morphism :=
          {|
            FO := inverse_morphism I;
            FA :=
              fun c d h =>
                match h in _ = y return
                      (inverse_morphism I c) = (inverse_morphism I y)
                with
                  eq_refl => eq_refl
                end
          |}
      |}.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (left_inverse I)); trivial.
    }
  Qed.

  Next Obligation.
  Proof.
    Func_eq_simpl.
    {
      FunExt; cbn in *.
      match goal with
        [|- ?A = ?B] => destruct A
      end.
      apply JMeq_eq; auto.
    }
    {
      FunExt; cbn.
      cbn_rewrite (equal_f (right_inverse I)); trivial.
    }
  Qed.

End Discr_Cat_Iso.
*)
(* Functor from SingletonCat to another category. *)
Section Func_From_SingletonCat.
  Context {C : Category} (Cobj : C).

  (** The functor from SingletonCat to C induced bo Cobj. *)
  Program Definition Func_From_SingletonCat : (SingletonCat –≻ C)%functor :=
    {|
      FO := fun _ => Cobj;
      FA := fun _ _ _ => id
    |}.

End Func_From_SingletonCat.

(* Discrete Functor *)
Section Discr_Func.
  Context {C : Category} {A : hSet} (Omap : A → C).

  (** The discrete functor – a functor from a discrete category of type A
 to a category C based on a function from A to objects of C. *)
  Program Definition Discr_Func : ((Discr_Cat A) –≻ C)%functor :=
    {|
      FO := Omap;

      FA := fun (a b : A) (h : a = b) =>
              match h in _ = y return ((Omap a) –≻ (Omap y))%morphism with
              | idpath => id
              end
    |}.

  (** The discrete-opposite functor – a functor from the opposite of a
discrete category of type A to a category C based on a function from A to objects of C. *)
  Program Definition Discr_Func_op : ((Discr_Cat A)^op –≻ C)%functor :=
    {|
      FO := Omap;
      FA := fun (a b : A) (h : b = a) =>
              match h in _ = y return ((Omap y) –≻ (Omap b))%morphism with
              | idpath => id
              end
    |}.

End Discr_Func.

Arguments Discr_Func {_ _} _, _ {_} _.
Arguments Discr_Func_op {_ _} _, _ {_} _.


Require Import VST.floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import sha.vst_lemmas.

Require Import sha.hmac_common_lemmas.
Require Import sha.spec_hmac.

Require Import sha.hkdf.
Require Import sha.spec_hkdf.
Require Import sha.hkdf_functional_prog.

Definition Done (i:Z): int := Int.repr (digest_len*i).
Definition OUTpred PrkCont InfoCont sh z r cont p: mpred:=
  data_at sh (tarray tuchar z) (sublist 0 z (map Vubyte (HKDF_expand PrkCont InfoCont cont))) p *
  memory_block sh r (offset_val z p).

Definition PREVcont PRK INFO (i: Z): reptype (Tarray tuchar 32 noattr) :=
     if zeq i 0 then list_repeat 32 Vundef
     else (map Vubyte (Ti (CONT PRK) (CONT INFO) (Z.to_nat i))).

Lemma PREV_len PRK INFO i: 0 <= i -> Zlength (PREVcont PRK INFO i) = 32.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). rewrite Zlength_list_repeat'; reflexivity.
assert (exists n, Z.to_nat i = S n).
{ specialize (Z2Nat_inj_0 i). intros.
  destruct (Z.to_nat i). omega. eexists; reflexivity. }
destruct H0; rewrite H0.
unfold Ti; simpl. repeat rewrite Zlength_map. apply HMAC_Zlength.
Qed.

Lemma PREVcont_Sn PRK INFO i p: 0 <= i <= Byte.max_unsigned -> PREVcont PRK INFO i = map Vubyte p ->
      PREVcont PRK INFO (i+1) = if zeq i 0 then map Vubyte (HMAC256_functional_prog.HMAC256 (CONT INFO ++ [Byte.one]) (CONT PRK))
                                else map Vubyte (HMAC256_functional_prog.HMAC256 (p ++ CONT INFO ++ [Byte.add (Byte.repr i) Byte.one]) (CONT PRK)).
Proof. intros. unfold PREVcont.
destruct (zeq (i+1) 0). omega.
change (i+1) with (Z.succ i). rewrite Z2Nat.inj_succ; try omega. simpl.
unfold PREVcont in H0.
destruct (zeq i 0).
+ subst i. simpl; trivial.
+ apply map_Vubyte_injective in H0. (* apply map_IntReprOfBytes_injective in H0; trivial.*)
  rewrite H0, Zpos_P_of_succ_nat, Z2Nat.id; trivial; try omega. repeat f_equal.
  unfold Z.succ, Byte.add, Byte.one. f_equal. rewrite 2 Byte.unsigned_repr; trivial; rep_omega.
Qed.

Lemma PREV_listbyte PRK INFO i: 0 < i -> exists l, PREVcont PRK INFO i = map Vubyte l.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). omega. eexists; reflexivity.
Qed.

Lemma sublist_HKDF_expand4 PRK INFO i rest l (REST : 0 <= rest < 32)
      (g : 255 >= i + 1) (OLEN : 32 * i + rest + 32 <= Int.max_unsigned)
      (Hl : if zeq i 0 then l = [] else PREVcont PRK INFO i = map Vubyte l)
      (Hi: 0 <= i):
sublist 0 rest
  (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [Byte.add (Byte.repr i) Byte.one]) (CONT PRK)) =
sublist (32 * i) (32 * i + rest) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold PREVcont in Hl. destruct (zeq i 0).
  + subst i l; simpl. rewrite Z.add_0_l. unfold HKDF_expand; simpl.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r. rewrite Byte.add_zero_l. reflexivity.
  + apply map_Vubyte_injective in Hl. subst.
    unfold HKDF_expand; simpl.
    destruct (zle (32 * (i + 1)) 0); try omega.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r.
    rewrite (Zmod_unique _ _ (i+1) 0); try omega. simpl.
    rewrite (Zdiv_unique _ _ (i+1) 0); try omega.
    replace (Z.to_nat (i+1)) with (S (Z.to_nat i)).
    2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
    simpl. rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
    rewrite Zminus_diag, <- app_assoc, Zpos_P_of_succ_nat, Z2Nat.id; try omega.
    replace ((32 * i + rest - 32 * i)%Z) with rest%Z by omega. repeat f_equal.
  unfold Z.succ, Byte.add, Byte.one. f_equal. rewrite 2 Byte.unsigned_repr; trivial; rep_omega.
Qed.

Lemma sublist_HKDF_expand5 PRK INFO l i
         (Hl : if zeq i 0 then l = []
               else PREVcont PRK INFO i = map Vubyte l)
         (Hi : 0 <= i <= Byte.max_unsigned):
      sublist 0 32 (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [Byte.add (Byte.repr i) Byte.one]) (CONT PRK)) =
      sublist (32 * i) (32 * i + 32) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold HKDF_expand. destruct (zle (32*(i + 1)) 0); try omega. simpl.
  rewrite (Zmod_unique _ _ (i+1) 0) by omega. simpl.
  rewrite (Zdiv_unique _ _(i+1) 0) by omega.
  rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)).
  2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
  simpl.
  rewrite Zpos_P_of_succ_nat, Z2Nat.id; try omega.
  rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
  rewrite Zminus_diag. replace ((32 * i + 32 - 32 * i)%Z) with 32%Z by omega.
  unfold PREVcont in Hl.
  destruct (zeq i 0). { simpl in *; subst i l; simpl; trivial. }
  apply map_Vubyte_injective in Hl.
  rewrite Hl, <- app_assoc. repeat f_equal.
  unfold Z.succ, Byte.add, Byte.one. f_equal. rewrite 2 Byte.unsigned_repr; trivial. rep_omega.
Qed.

Lemma body_hkdf_expand: semax_body Hkdf_VarSpecs Hkdf_FunSpecs
       f_HKDF_expand HKDF_expand_spec.
Proof.
start_function.
rename H into LenPRK. rename H0 into LEN_INFO1.
destruct H1 as [LEN_INFO2 LEN_INFO3]. rename H2 into OLEN.

freeze FR1 := - .
forward. forward. forward. forward.
{ entailer!. inv H. }
unfold Int.divu, Int.add, Int.sub.
assert (OLEN2: 0 <= (olen + 32 - 1) / 32 <= Int.max_unsigned).
{ split. apply Z_div_pos; omega.
  apply Zdiv_le_upper_bound; omega. }
rewrite (Int.unsigned_repr 32); [| rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr olen); [| omega].
rewrite (Int.unsigned_repr 1); [| rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr (Int.unsigned (Int.repr (olen + 32)) - 1));
  [| rewrite Int.unsigned_repr; omega].
rewrite Int.unsigned_repr; [| omega].
forward_if
  (EX v:_,
   PROP (if zlt (olen + 32) olen then v = Vint (Int.repr 1)
         else v = Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32))) )
   LOCAL (temp _t'1 v;
   temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvars gv)  SEP (FRZL FR1)).
{ forward. Exists (Vint (Int.repr 1)). erewrite zlt_true; try eapply H.
  entailer!. }
{ forward.
  Exists (Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32)))).
  rewrite if_false; trivial.
  entailer!. unfold sem_cast, sem_cast_i2bool, Val.of_bool; simpl.
  destruct (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32))); simpl; reflexivity. }
apply extract_exists_pre. intros v. Intros. rename H into HV.
unfold Int.ltu in HV.
rewrite Int.unsigned_repr in HV; [| rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega].
rewrite Int.unsigned_repr in HV; [| omega].
unfold Val.of_bool in HV.
forward_if
  (PROP (v=Vint (Int.repr 0))
   LOCAL (temp _t'1 v; temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   (*gvar sha._K256 kv*)gvars gv)  SEP (FRZL FR1)).
{ unfold typed_true in H.
  rewrite if_false in HV; try omega.
  subst v.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); [clear H | inv H].
  forward. normalize.
  Exists (expand_out_post shmd (CONT PRK) (CONT INFO) olen out).
  entailer!.
  + unfold expand_out_post, digest_len; simpl.
    rewrite if_false; try omega.
    rewrite if_true; trivial.
  + thaw FR1.
    unfold expand_out_post, digest_len; simpl.
    rewrite if_false; try omega.
    rewrite if_true; trivial. simpl. cancel. }
{ forward. entailer!. unfold typed_false in H; simpl in H; inv H.
  destruct (zlt (olen + 32) olen). inv HV; simpl in *; try discriminate.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); inv HV; simpl in *; try discriminate; trivial. }
Intros. subst v. rewrite if_false in HV; try omega.
destruct (zlt 255 ((olen + 32 - 1) / 32)); [inv HV | clear HV].
drop_LOCAL 0%nat.
thaw FR1.
Time assert_PROP (isptr prk) as isPtrPrk by entailer!.

freeze FR1 := - (data_at_ _ _ v_hmac) (data_block _ _ prk) (spec_sha.K_vector _).
assert_PROP (field_compatible t_struct_hmac_ctx_st [] v_hmac) as FC_hmac by entailer!.
replace_SEP 1 (HMAC_SPEC.EMPTY Tsh v_hmac).
{ entailer!. eapply HMAC_SPEC.mkEmpty; trivial. }
idtac "Timing the call to _HMAC_Init".
Time forward_call (@inr (share * val * Z * list byte * globals) _ (Tsh,v_hmac, spec_hmac.LEN PRK, CONT PRK, (*kv*)gv, prk)).
(*Finished transaction in 1.717 secs (1.371u,0.017s) (successful)*)

remember ((olen + 32 - 1) / 32) as bnd.
thaw FR1.
assert_PROP (isptr v_previous /\ field_compatible (tarray tuchar 64) [] v_previous) as prevPtr by entailer!.
destruct prevPtr as [prevPtr prevFC].

unfold data_at_ at 2. unfold field_at_.
rewrite field_at_data_at. simpl. unfold tarray.
assert (JM: default_val (Tarray tuchar 64 noattr) = sublist 0 64 (list_repeat 64 Vundef)).
{ (*subst vv.*) rewrite sublist_list_repeat with (k:=64); try omega; reflexivity. }
erewrite  split2_data_at_Tarray with (n1:=32); [ | omega | | apply JM | reflexivity | reflexivity].
 2: rewrite Zlength_list_repeat'; simpl; omega.
normalize.
rewrite field_address_offset by auto with field_compatible. simpl.
rewrite isptr_offset_val_zero; trivial.
rewrite field_address0_offset by auto with field_compatible. simpl.
rewrite memory_block_field_compatible_tarraytuchar by rep_omega.
Intros. rename H into FCout.

freeze FR0 := (data_at _ _ _ (offset_val 32 v_previous)) (data_block _ _ prk).

assert_PROP (isptr out) as isPTRout by entailer!.
assert (Arith: 32 > 0) by omega.
specialize (Z_div_mod_eq olen 32 Arith); intros OLEN1.
assert (REST:= Z_mod_lt olen 32 Arith). remember (olen / 32) as rounds. remember (olen mod 32) as rest.
assert (BND: bnd = if zeq rest 0 then rounds else rounds + 1).
{ subst bnd olen. clear Heqrounds Heqrest.
  destruct (zeq rest 0).
  + subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega. rewrite X; clear X.
    symmetry. eapply Zdiv.Zdiv_unique. 2: reflexivity. omega.
  + assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega. rewrite X; clear X.
    rewrite Z.div_add_l. f_equal. apply Zdiv_unique with (b:=rest -1); omega. omega. }
clear Heqbnd Heqrounds Heqrest.

forward_for_simple_bound bnd
       (EX ii:Z, PROP (0 <= olen - Int.unsigned(if zlt ii bnd then Done ii else Int.repr olen))
             LOCAL (temp _n (Vint (Int.repr bnd));
                    temp _ret (Vint (Int.repr 0));
                    temp _done (Vint (if zlt ii bnd then Done ii else Int.repr olen));
                    temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
                    lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac; lvar _previous (tarray tuchar 64) v_previous;
                    temp _out_key out; temp _out_len (Vint (Int.repr olen)); temp _prk prk;
                    temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK))); temp _info info;
                    temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO))); gvars gv)
             SEP (FRZL FR0; spec_sha.K_vector gv; data_at_ Tsh tuchar v_ctr;
            data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO ii) v_previous;
            data_block Tsh (CONT INFO) info;
            if zeq ii 0 then HMAC_SPEC.REP Tsh (HMAC_SPEC.hABS (CONT PRK) []) v_hmac
            else HMAC_SPEC.FULL Tsh (CONT PRK) v_hmac;
            OUTpred (CONT PRK) (CONT INFO) shmd (Z.min (digest_len * ii) olen)
                    (olen - Z.min (digest_len * ii) olen) (ii*32) out)).
{ destruct (zeq 0 0); try solve [omega]. clear e; entailer!.
  + unfold Done; simpl.
    destruct (zeq rest 0); simpl.
    - subst rest.
      destruct (zlt 0 rounds); simpl.
      * split; trivial. rewrite Int.unsigned_repr; omega.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. split; trivial; omega.
    - rewrite if_true. 2: omega. split; trivial. rewrite Int.unsigned_repr; omega.
  + unfold OUTpred. destruct (zeq rest 0).
    - subst rest; simpl.
      destruct (zlt 0 rounds); simpl.
      * rewrite Zplus_0_r, Z.min_l, Zminus_0_r, data_at_tuchar_zero_array_eq, isptr_offset_val_zero; trivial; try omega.
        cancel.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. unfold tarray.
        rewrite isptr_offset_val_zero, data_at_tuchar_zero_array_eq; trivial. cancel.
    - rewrite Z.min_l by omega. rewrite Zminus_0_r, data_at_tuchar_zero_array_eq; trivial.
      rewrite isptr_offset_val_zero; trivial. cancel.
}

{ (*loop body*)
  rename H into Hi1. Intros. rename i into i1. rename H into olenBounded. unfold Done, digest_len in olenBounded.
   rewrite if_true in olenBounded; try omega.
   rewrite Int.unsigned_repr in olenBounded. 2: rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega.

  forward. rewrite Z.min_l by (unfold digest_len; omega).

  forward_if (EX l:_,
  PROP ( if zeq i1 0 then l=@nil byte  else PREVcont PRK INFO i1 = map Vubyte l)
   LOCAL (temp _i (Vint (Int.repr i1)); temp _n (Vint (Int.repr bnd));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (if zlt i1 bnd then Done i1 else Int.repr olen));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (LEN PRK))); temp _info info;
   temp _info_len (Vint (Int.repr (LEN INFO))); gvars gv)
   SEP (FRZL FR0; spec_sha.K_vector gv;
   field_at Tsh tuchar []
     (Vint (cast_int_int I8 Unsigned (Int.add (Int.repr i1) (Int.repr 1)))) v_ctr;
   data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO i1) v_previous;
   data_block Tsh (CONT INFO) info;
   OUTpred (CONT PRK) (CONT INFO) shmd (digest_len * i1) (olen - digest_len * i1) (i1*32) out;
   HMAC_SPEC.REP Tsh (HMAC_SPEC.hABS (CONT PRK) l) v_hmac)).

   { destruct (zlt i1 bnd); try omega. rewrite if_false; trivial.
     freeze FR1 := - (spec_sha.K_vector _) (data_at _ _ _ v_previous) (HMAC_SPEC.FULL _ _ v_hmac).
     idtac "Timing the call to _HMAC_Init".
     Time forward_call (@inl _ (share * val * Z * list byte * globals * val) (Tsh, v_hmac,0,CONT PRK, gv)).
     (* Finished transaction in 1.73 secs (1.472u,0.011s) (successful)*)
     destruct (PREV_listbyte PRK INFO i1) as [prev Hprev]; [ omega | rewrite Hprev ].
     assert (Zlength_prev: Zlength prev = 32).
     { specialize (PREV_len PRK INFO i1). rewrite Hprev.
       rewrite Zlength_map. intros X; rewrite X; trivial. omega. }

     idtac "Timing the first call to _HMAC_Update".
     Time forward_call (CONT PRK, v_hmac, Tsh, v_previous, Tsh, @nil byte, prev, gv).
     (*Finished transaction in 2.55 secs (2.048u,0.005s) (successful)*)
     * rewrite Zlength_prev. (*, sem_cast_neutral_ptr; trivial. *)
       apply prop_right; split; trivial.
     * assert (Frame = [FRZL FR1]). subst Frame; reflexivity. simpl; cancel.
       unfold data_block, tarray. rewrite Zlength_prev; trivial.
     * rewrite Zlength_prev, Zlength_nil.
       split. apply writable_share_top. split. apply readable_share_top.
       rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega.
     * Exists prev. rewrite if_false; trivial. entailer!. thaw FR1. cancel.
       unfold data_block. normalize. rewrite Hprev, Zlength_prev. simpl app; cancel. }
   { subst i1. forward. Exists (@nil byte). rewrite ! if_true; try omega.
     entailer!. }

   apply extract_exists_pre. intros l. Intros. rename H into Hl. rewrite if_true by omega.

   idtac "Timing the second call to _HMAC_Update".
   Time forward_call (CONT PRK, v_hmac, Tsh, info, Tsh, l, CONT INFO, gv).
   (* Finished transaction in 2.659 secs (2.094u,0.014s) (successful)*)
   { rewrite LEN_INFO1.
     apply prop_right. split; reflexivity. }
   { split. apply writable_share_top. split. apply readable_share_top. split. omega.
     destruct (zeq i1 0).
     + subst i1 l. rewrite Zlength_nil, Zplus_0_r. omega.
     + assert (Arith1: 0<= i1) by omega. specialize (PREV_len PRK INFO i1 Arith1); intros HZ.
       rewrite Hl, Zlength_map in HZ; rewrite HZ, <- Zplus_assoc; simpl. omega. }

   freeze FR3 := - (HMAC_SPEC.REP _ _ _) (spec_sha.K_vector _)
            (field_at _ _ _ _ v_ctr).
   assert_PROP (field_compatible (tarray tuchar 1) [] v_ctr /\ isptr v_ctr) as HH by entailer!.
   destruct HH as [FC_cptr isptrCtr].

   replace_SEP 3 (data_at Tsh (tarray tuchar 1) [Vint (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))] v_ctr).
   { entailer!. apply data_at_tuchar_singleton_array. }
   assert (LENB: Zlength [Byte.add (Byte.repr i1) Byte.one]= 1) by reflexivity.

   idtac "Timing the third call to _HMAC_Update".
   Time forward_call (CONT PRK, v_hmac, Tsh, v_ctr, Tsh, l++CONT INFO, [Byte.add (Byte.repr i1) Byte.one], gv).
   (* Finished transaction in 2.64 secs (2.057u,0.004s) (successful)*)
   { assert (Frame = [FRZL FR3]). subst Frame; reflexivity. subst Frame. simpl. cancel. apply data_at_ext_derives; trivial.
     simpl. unfold Vubyte, Int.add. rewrite <- verif_hmac_init_part2.isbyte_zeroExt8. f_equal. f_equal.
     unfold Byte.add.
     rewrite 2 Int.unsigned_repr; try (rewrite hmac_pure_lemmas.int_max_unsigned_eq; omega).
     unfold Byte.one; rewrite ! Byte.unsigned_repr; trivial; try rep_omega.
     rewrite ! Byte.unsigned_repr; trivial; try rep_omega.
     rewrite ! Int.unsigned_repr; trivial; try rep_omega. }
   { split. apply writable_share_top. split. apply readable_share_top.
     rewrite LENB. rewrite hmac_pure_lemmas.int_max_unsigned_eq, Zlength_app. split. omega.
     destruct (zeq i1 0).
     + subst l; rewrite Zlength_nil. rewrite Z.add_0_l. omega.
     + specialize (PREV_len PRK INFO i1). rewrite Hl, Zlength_map.
       intros HH; rewrite HH; omega. }

   normalize. thaw FR3.
   freeze FR4 := - (HMAC_SPEC.REP _ _ v_hmac) (spec_sha.K_vector _)
                     (data_at _ _ _ v_previous).
   replace_SEP 3 (memory_block Tsh 32 v_previous).
   { entailer!. eapply derives_trans. apply data_at_memory_block. simpl; trivial. }
   idtac "Timing the call to _HMAC_Final".
   Time forward_call (((l ++ CONT INFO) ++ [Byte.add (Byte.repr i1) Byte.one]),
                 CONT PRK, v_hmac, Tsh, v_previous, Tsh, gv).
   (* Finished transaction in 2.64 secs (2.057u,0.004s) (successful)*)
   unfold data_block.
   rewrite HMAC_Zlength.
   remember (HMAC256_functional_prog.HMAC256
                   ((l ++ CONT INFO) ++
                    [Byte.add (Byte.repr i1) Byte.one])
                   (CONT PRK)) as CONTRIB.
   forward.
   forward_if
  (PROP ( )
   LOCAL (temp _todo (if zlt olen
                             (Int.unsigned (Int.add (Done i1) (Int.repr 32)))
                      then Vint (Int.sub (Int.repr olen) (Done i1))
                      else Vint (Int.repr 32));
   temp _i (Vint (Int.repr i1));
   temp _n (Vint (Int.repr bnd)); temp _ret (Vint (Int.repr 0));
   temp _done (Vint (Done i1)); temp _digest_len (Vint (Int.repr 32));
   lvar _ctr tuchar v_ctr; lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous;
   temp _out_key out; temp _out_len (Vint (Int.repr olen));
   temp _prk prk; temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvars gv)
   SEP (data_at Tsh (tarray tuchar 32) (map Vubyte CONTRIB) v_previous;
   spec_sha.K_vector gv; HMAC_SPEC.FULL Tsh (CONT PRK) v_hmac; FRZL FR4)).
   { forward. entailer!. rewrite if_true; trivial; omega. }
   { forward. entailer!. rewrite if_false; trivial; omega. }

   thaw FR4.
   unfold OUTpred, Done, digest_len. normalize.
   freeze FR5 := - (memory_block _ _ (offset_val (32*i1) out))
                       (data_at _ _ _ v_previous).
   idtac "Timing the call to _memcpy".
   Time forward_call ((Tsh, shmd),
                 offset_val (32*i1) out, v_previous,
                 olen - (32* i1), 32,
             if zlt olen (32 * i1 + 32)
             then olen - 32 * i1
             else 32, CONTRIB).
   (* Finished transaction in 4.255 secs (3.485u,0.006s) (successful)*)
   { destruct (zlt olen (32 * i1 + 32)); simpl; entailer!. }
   { split. apply readable_share_top. split. trivial.
     destruct (zlt olen (32 * i1 + 32)); omega. }
   forward.

   (* establish loop invariant*)
   destruct (zeq (i1 + 1) 0); try omega.
   destruct (zlt olen (32 * i1 + 32)).
   + entailer!.
     * clear - OLEN2 olenBounded OLEN Hi1 REST l0. unfold Done, digest_len in *. simpl.
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds); rewrite Int.unsigned_repr; omega.
       - destruct (zlt (i1 + 1) (rounds+1)). rewrite Int.unsigned_repr; omega.
         rewrite Int.unsigned_repr; try omega. split. omega. f_equal. f_equal. omega.
     * thaw FR5. destruct out; try contradiction. simpl. rewrite Zminus_diag, memory_block_zero_Vptr. cancel.
       clear H1 H2 H (*AC SC*) H4 H5.
       unfold data_block. simpl. rewrite LENB, data_at_tuchar_singleton_array_eq. cancel.
       rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont; simpl; trivial.
         ++ erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. rep_omega.
       - unfold OUTpred, digest_len. simpl.
         destruct (zeq rest 0).
         ++ subst rest; simpl. rewrite Zplus_0_r in *. omega.
         ++ destruct (zlt (i1 + 1) (rounds + 1)); try solve [omega].
            assert (i1 = rounds) by omega. subst i1.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite Z.min_r; [| omega].
            rewrite Zminus_diag, memory_block_zero_Vptr; try solve [omega].
            replace (((rounds + 1)*32)%Z) with ((32 * (rounds + 1) + 0)%Z) by omega.
            rewrite (split2_data_at_Tarray_tuchar shmd (32 * rounds + rest) (32 * rounds)); simpl; trivial; try omega.

            2: { rewrite Zlength_sublist; try omega.
                     rewrite Zlength_map.
                     rewrite Zlength_HKDF_expand; simpl; omega. }
            unfold tarray; cancel.
               rewrite field_address0_offset; simpl.
               2: eapply field_compatible0_cons_Tarray; [ reflexivity | trivial | omega].
            entailer!. rewrite sublist_sublist; try omega.
            rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite ! sublist_map.

            replace (rounds * 32)%Z with (32*rounds)%Z by omega.
            rewrite sublist_HKDF_expand4, <- sublist_HKDF_expand2; trivial; try omega.
            cancel.

   + entailer!.
     * clear H H0 H1 H2 H3 H4 H5. unfold Done, digest_len in *. simpl.
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
       - destruct (zlt (i1 + 1) (rounds+1)).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
     * thaw FR5. cancel.
       unfold data_block, digest_len. normalize. rewrite LENB, data_at_tuchar_singleton_array_eq. cancel.
       rewrite Z.min_l by omega.
       repeat rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont. simpl; trivial.
         ++ clear - Hl n0 Hi1 g. erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. rep_omega.
       - unfold OUTpred, digest_len. simpl. rewrite Z.mul_add_distr_l, Z.mul_1_r.
         destruct (zeq rest 0).
         ++ subst rest; simpl in *. rewrite Zplus_0_r in *.
            destruct (zlt (i1+1) rounds).
            ** replace (32 * rounds - (32 * i1 + 32)) with (32 * rounds - 32 * i1 - 32) by omega. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1+32) (32 * i1)); simpl; trivial; try omega.
               -- unfold tarray.
                  replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                  rewrite field_address0_offset; simpl.
                  2: { eapply field_compatible0_cons_Tarray. reflexivity.
                           eapply field_compatible_array_smaller0. apply FCout. omega. omega. }
                  rewrite sublist_sublist; try omega.
                  rewrite sublist_sublist; try omega.
                  rewrite ! sublist_map, !  Z.mul_1_l, ! Z.add_0_r, ! Z.add_0_l.
                  clear - Hl Hi1 g.
                  replace ((i1 + 1) * 32)%Z with (32*(i1 + 1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite <- sublist_HKDF_expand2; try omega.
                  erewrite <- sublist_HKDF_expand5; try rep_omega; try eassumption. cancel.
              -- rewrite Zlength_sublist; try omega. rewrite ! Zlength_map.
                 replace ((i1 + 1) * 32)%Z with ((32 * (i1 + 1))+0) by omega.
                 rewrite Zlength_HKDF_expand; omega.
            ** assert (rounds = i1+1) by omega. subst rounds; simpl in *.
               replace (32 * (i1 + 1))%Z with ((32 * i1 + 32)%Z) by omega.
               replace (32 * i1 + 32 - 32 * i1 - 32)%Z with 0%Z by omega.
               rewrite Zminus_diag, memory_block_zero. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1 + 32) (32 * i1)); simpl; trivial; try omega.
               -- replace ((32 * i1 + 32 - 32 * i1)%Z) with 32%Z by omega.
                  rewrite field_address0_offset by auto with field_compatible. simpl.
                  repeat rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r, ! Z.add_0_l, ! Z.mul_1_l.
                  unfold tarray; rewrite sepcon_comm.
                  replace ((i1 + 1) * 32)%Z with (32*(i1+1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite ! sublist_map, <- (sublist_HKDF_expand5 PRK INFO l i1 Hl),
                    <- sublist_HKDF_expand2; try rep_omega; cancel.
               -- rewrite Zlength_sublist; try omega. rewrite Zlength_map.
                  replace (((i1 + 1)*32)%Z) with ((32 * (i1 + 1) + 0)%Z) by omega.
                  rewrite Zlength_HKDF_expand; omega.
          ++ replace (32 * rounds + rest - 32 * i1 - 32)%Z with (32 * rounds + rest - (32 * i1 + 32))%Z by omega.
             cancel.

             rewrite (split2_data_at_Tarray_tuchar shmd (32*i1 + 32) (32*i1)); simpl; trivial; try omega.
                ** rewrite field_address0_offset; simpl. rewrite Z.mul_1_l, Z.add_0_l.
                   rewrite ! sublist_map, ! sublist_sublist, ! Z.add_0_r; try omega.
                   replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                   replace ((i1 + 1)*32)%Z with (32*(i1+1))%Z by omega.
                   replace (i1*32)%Z with (32*i1)%Z by omega.
                   rewrite <- (sublist_HKDF_expand5 PRK INFO l i1 Hl), <- sublist_HKDF_expand2; try rep_omega. cancel.
                   eapply field_compatible0_cons_Tarray; [ reflexivity | | omega].
                   eapply field_compatible_array_smaller0; [ apply FCout | omega].
                ** rewrite ! sublist_map, ! Zlength_map, Zlength_sublist; try omega.
                   replace ((i1 + 1) * 32)%Z with (32 * (i1+1) + 0)%Z by omega.
                   rewrite Zlength_HKDF_expand; omega. }
(*Continuation after loop*)
  normalize. rewrite if_false in H. 2: omega. clear H. (*eliminate this PROP in loop invariant entirely?*)

  forward.
  freeze FR6 := - (if zeq bnd 0 then _ else _).

  idtac "Timing the call to _HMAC_cleanup".
  Time forward_call (CONT PRK, v_hmac, Tsh).
  (* Finished transaction in 1.589 secs (1.371u,0.004s) (successful)*)
    { assert (Frame = [FRZL FR6]). subst Frame; reflexivity.
      subst Frame; simpl. cancel.
      destruct (zeq bnd 0); trivial. apply HMAC_SPEC.REP_FULL. }
  forward. forward.
     Exists (expand_out_post shmd (CONT PRK) (CONT INFO) (32 * rounds + rest) out).
     Time entailer!.
     + unfold expand_out_post, digest_len.
       rewrite if_false. 2: omega.
       rewrite if_false. simpl; trivial.
       destruct (zeq rest 0); simpl in *.
       - subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega.
         rewrite X; clear X. erewrite <- Zdiv.Zdiv_unique. 3: reflexivity. omega. omega.
       - assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega.
         rewrite X; clear X.
         rewrite Z.div_add_l; try omega.
         erewrite Zdiv_unique with (b:=rest -1)(a:=1); omega.
     + thaw FR6. thaw FR0. cancel. unfold expand_out_post, digest_len.
        rewrite 2 sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives; [| apply HMAC_SPEC.EmptyDissolve].
        rewrite <- sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives.
        - destruct (zlt (32 * rounds + rest + 32) (32 * rounds + rest)); try omega.
          destruct (zlt (if zeq rest 0 then rounds else rounds + 1) (if zeq rest 0 then rounds else rounds + 1)); try omega.
          unfold OUTpred, data_block.
          rewrite Z.min_r by (destruct (zeq rest 0); omega).
          rewrite Zminus_diag, memory_block_zero, Zlength_HKDF_expand; try omega. normalize.
          destruct (zlt 255 ((32 * rounds + rest + 32 - 1) / 32)).
          { exfalso. destruct (zeq rest 0).
            + subst rest; simpl in *. replace (32 * rounds + 0 + 32 - 1)%Z with (rounds * 32 + 31) in l by omega.
              rewrite Z_div_plus_full_l, Zdiv_small in l; omega.
            + replace (32 * rounds + rest + 32 - 1)%Z with (rounds * 32 + (rest + 31))%Z in l by omega.
              rewrite Z_div_plus_full_l in l; try omega. erewrite (Zdiv_unique _ _ 1 ((rest + 31)-32)) in l; omega. }
          simpl.
          apply data_at_ext_derives; trivial.
          destruct (zeq rest 0).
          * subst rest; simpl. rewrite Z.add_0_r, sublist_same, Z.mul_comm; trivial.
            rewrite ! Zlength_map. replace ((rounds*32)%Z) with ((32 * rounds + 0)%Z) by omega.
            rewrite Zlength_HKDF_expand; omega.
          * replace ((rounds + 1)*32)%Z with (32 * rounds + 32)%Z by omega.
            rewrite sublist_map. f_equal.
            apply sublist_HKDF_expand3; omega.
        - rewrite (split2_data_at__Tarray_tuchar Tsh 64 32); simpl; trivial; try omega.
          rewrite field_address0_offset. cancel.
          eapply field_compatible0_cons_Tarray; [reflexivity | trivial | omega].
Time Qed.
  (*Finished transaction in 8.645 secs (8.647u,0.s) (successful)*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Monoid_cat.
(** Title "The monoid of maps of a set into itself." *)
Section Def.
Variable E : SET.

Definition endo_comp : law_of_composition (Hom E E).
unfold law_of_composition in |- *.
apply
 (Build_Map
    (Ap:=fun x : cart (Hom E E) (Hom E E) => comp_map_map (proj1 x) (proj2 x))).
red in |- *.
auto with algebra.
Defined.

Definition Endo_SET_sgroup : SGROUP.
apply (Build_sgroup (sgroup_set:=Hom E E)).
apply (Build_sgroup_on (E:=Hom E E) (sgroup_law_map:=endo_comp)).
red in |- *.
simpl in |- *.
unfold Map_eq in |- *; auto with algebra.
Defined.

Definition Endo_SET : MONOID.
apply (Build_monoid (monoid_sgroup:=Endo_SET_sgroup)).
apply (Build_monoid_on (A:=Endo_SET_sgroup) (monoid_unit:=Id E)).
red in |- *.
simpl in |- *.
unfold Map_eq in |- *; auto with algebra.
red in |- *.
simpl in |- *.
unfold Map_eq in |- *; auto with algebra.
Defined.
End Def.


(***************************************************************************
* Safety for STLC with Exceptions - Definitions                            *
* Arthur Charguéraud, July 2007                                            *
***************************************************************************)

Set Implicit Arguments.
Require Import LibLN.

(** Grammar of types. *)

Parameter atm : Set.

Inductive typ : Set :=
  | typ_exn : typ
  | typ_var : atm -> typ
  | typ_arrow  : typ -> typ -> typ.

(** Grammar of pre-terms. *)

Inductive trm : Set :=
  | trm_bvar : nat -> trm
  | trm_fvar : var -> trm
  | trm_abs  : trm -> trm
  | trm_app  : trm -> trm -> trm
  | trm_raise : trm -> trm
  | trm_catch : trm -> trm -> trm.

(** Opening up abstractions *)

Fixpoint open_rec (k : nat) (u : trm) (t : trm) {struct t} : trm :=
  match t with
  | trm_bvar i    => If k = i then u else (trm_bvar i)
  | trm_fvar x    => trm_fvar x
  | trm_abs t1    => trm_abs (open_rec (S k) u t1)
  | trm_app t1 t2 => trm_app (open_rec k u t1) (open_rec k u t2)
  | trm_raise t1  => trm_raise (open_rec k u t1)
  | trm_catch t1 t2 => trm_catch (open_rec k u t1) (open_rec k u t2)
  end.

Definition open t u := open_rec 0 u t.

Notation "{ k ~> u } t" := (open_rec k u t) (at level 67).
Notation "t ^^ u" := (open t u) (at level 67).
Notation "t ^ x" := (open t (trm_fvar x)).

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

Inductive term : trm -> Prop :=
  | term_var : forall x,
      term (trm_fvar x)
  | term_abs : forall L t1,
      (forall x, x \notin L -> term (t1 ^ x)) ->
      term (trm_abs t1)
  | term_app : forall t1 t2,
      term t1 -> term t2 -> term (trm_app t1 t2)
  | term_raise : forall t1,
      term t1 ->
      term (trm_raise t1)
  | term_catch : forall t1 t2,
      term t1 ->
      term t2 ->
      term (trm_catch t1 t2).

(** Environment is an associative list mapping variables to types. *)

Definition env := LibEnv.env typ.

(** Typing relation *)

Reserved Notation "E |= t ~: T" (at level 69).

Inductive typing : env -> trm -> typ -> Prop :=
  | typing_var : forall E x T,
      ok E ->
      binds x T E ->
      E |= (trm_fvar x) ~: T
  | typing_abs : forall L E U T t1,
      (forall x, x \notin L -> (E & x ~ U) |= t1 ^ x ~: T) ->
      E |= (trm_abs t1) ~: (typ_arrow U T)
  | typing_app : forall S T E t1 t2,
      E |= t1 ~: (typ_arrow S T) -> E |= t2 ~: S ->
      E |= (trm_app t1 t2) ~: T
  | typing_raise : forall E t1 T,
      E |= t1 ~: typ_exn ->
      E |= (trm_raise t1) ~: T
  | typing_catch : forall E t1 t2 T,
      E |= t1 ~: (typ_arrow typ_exn T) ->
      E |= t2 ~: T ->
      E |= (trm_catch t1 t2) ~: T

where "E |= t ~: T" := (typing E t T).

(** Definition of values (only abstractions are values) *)

Inductive value : trm -> Prop :=
  | value_abs : forall t1,
      term (trm_abs t1) -> value (trm_abs t1).

(** Exception generation *)

Inductive fails : trm -> trm -> Prop :=
  | fails_raise_val : forall t1,
      value t1 ->
      fails (trm_raise t1) t1
  | fails_raise_1 : forall t1 e,
      fails t1 e ->
      fails (trm_raise t1) e
  | fails_app_1 : forall t1 t2 e,
      term t2 ->
      fails t1 e ->
      fails (trm_app t1 t2) e
  | fails_app_2 : forall t1 t2 e,
      value t1 ->
      fails t2 e ->
      fails (trm_app t1 t2) e.

(** Reduction relation - one step in call-by-value *)

Inductive red : trm -> trm -> Prop :=
  | red_beta : forall t1 t2,
      term (trm_abs t1) ->
      value t2 ->
      red (trm_app (trm_abs t1) t2) (t1 ^^ t2)
  | red_app_1 : forall t1 t1' t2,
      term t2 ->
      red t1 t1' ->
      red (trm_app t1 t2) (trm_app t1' t2)
  | red_app_2 : forall t1 t2 t2',
      value t1 ->
      red t2 t2' ->
      red (trm_app t1 t2) (trm_app t1 t2')
  | red_catch_2 : forall t1 t2 t2',
      term t1 ->
      red t2 t2' ->
      red (trm_catch t1 t2) (trm_catch t1 t2')
  | red_catch_val : forall t1 t2,
      term t1 ->
      value t2 ->
      red (trm_catch t1 t2) t2
  | red_catch_exn : forall t1 t2 e,
      term t1 ->
      fails t2 e ->
      red (trm_catch t1 t2) (trm_app t1 e)
  | red_raise_1 : forall t1 t1',
      red t1 t1' ->
      red (trm_raise t1) (trm_raise t1').

Notation "t --> t'" := (red t t') (at level 68).

(** Goal is to prove preservation and progress *)

Definition preservation := forall E t t' T,
  E |= t ~: T ->
  t --> t' ->
  E |= t' ~: T.

Definition progress := forall t T,
  empty |= t ~: T ->
     value t
  \/ (exists e, fails t e)
  \/ (exists t', t --> t').


(******************************************************************************)
(* Properties of the LLVM IR semantics.                                       *)
(******************************************************************************)

Require ndopsem.
Require Import Coq.ZArith.ZArith.
Require Import Coq.ZArith.Zdiv.
Require Import Tvc.base_tactics.

Lemma repr_unsigned_inverse :
  forall (w : nat) (n : Integers.Int.int w), eq n (Integers.Int.repr w (Integers.Int.unsigned w n)).
Proof.
  intros.
  unfold Integers.Int.repr, Integers.Int.unsigned.
  destruct n.
  simpl.

  pose proof intrange as H2.
  pose proof (Zmod_small intval (Integers.Int.modulus w)) as H4.
  apply H4 in H2.
  clear H4.

  remember (Z_mod_lt intval (Integers.Int.modulus w) (Integers.Int.modulus_pos w)) as intrange2.
  clear Heqintrange2.

  remember ((intval mod (Integers.Int.modulus w))%Z) as intval2.
  clear Heqintval2.

  destruct H2.
  replace intrange with intrange2 by (apply Axioms.proof_irr).
  reflexivity.
Qed.

Lemma unsigned_repr_inverse :
  forall (w : nat) (z : Z), eq (z mod Integers.Int.modulus w)%Z (Integers.Int.unsigned w (Integers.Int.repr w z)).
Proof.
  reflexivity.
Qed.

Lemma repr_signed_inverse :
  forall (w : nat) (n : Integers.Int.int w), eq n (Integers.Int.repr w (Integers.Int.signed w n)).
Proof.
  intros.
  unfold Integers.Int.repr, Integers.Int.signed.
  destruct n.
  simpl.

  destruct (Coqlib.zlt intval (Integers.Int.half_modulus w)).

  (* case 1: intval < half_modulus *)
  pose proof intrange as H2.
  pose proof (Zmod_small intval (Integers.Int.modulus w)) as H4.
  apply H4 in H2.
  clear H4.

  remember (Z_mod_lt intval (Integers.Int.modulus w) (Integers.Int.modulus_pos w)) as intrange2.
  clear Heqintrange2.

  remember ((intval mod (Integers.Int.modulus w))%Z) as intval2.
  clear Heqintval2.

  destruct H2.
  replace intrange with intrange2 by (apply Axioms.proof_irr).
  reflexivity.

  (* case 2: intval >= half_modulus *)
  assert (eq ((intval - Integers.Int.modulus w) mod (Integers.Int.modulus w))%Z intval) as H2.
  rewrite Zminus_mod.
  rewrite Z_mod_same; [ | omega ].
  rewrite Zminus_0_r.
  rewrite Zmod_mod.
  pose proof intrange as H2.
  pose proof (Zmod_small intval (Integers.Int.modulus w)) as H4.
  apply H4 in H2.
  assumption.

  remember (Z_mod_lt (intval - Integers.Int.modulus w) (Integers.Int.modulus w) (Integers.Int.modulus_pos w)) as intrange2.
  clear Heqintrange2.

  remember (((intval - Integers.Int.modulus w) mod (Integers.Int.modulus w))%Z) as intval2.
  clear Heqintval2.

  destruct H2.
  replace intrange with intrange2 by (apply Axioms.proof_irr).
  reflexivity.
Qed.

Lemma ltb_false_geb_true n m : (n <? m)%Z = false <-> (n >=? m)%Z = true.
Proof.
  unfold Z.ltb, Z.geb.
  split; intro; destruct (n ?= m)%Z eqn:?; auto.
Qed.

Lemma leb_false_gtb_true n m : (n <=? m)%Z = false <-> (n >? m)%Z = true.
Proof.
  unfold Z.leb, Z.gtb.
  split; intro; destruct (n ?= m)%Z eqn:?; auto.
Qed.

Lemma technical_1 :
  forall z m : Z,
    (m > 0)%Z ->
    (- (m / 2) <= z)%Z ->
    (z < 0)%Z ->
    eq (z mod m)%Z (z + m)%Z.
Proof.
  intros.

  rewrite Zmod_eq; [ | omega ].
  apply Zplus_eq_compat; [ reflexivity | ].

  assert (eq (z / m) (-1))%Z as H'.

  assert (eq ((z + m) / m) 0)%Z.
  apply Z.div_small.
  split.

  rewrite Z.add_comm.
  apply (Zplus_le_compat_l (-(m/2)) z m) in H0.
  rewrite Z.add_opp_r in H0.
  assert (m - m/2 >= 0)%Z.

  apply Z.le_ge.
  apply (Zplus_le_reg_l _ _ (m/2)).
  rewrite Z.add_0_r.
  rewrite Zplus_minus.

  assert (0 <= m)%Z as H2 by omega.
  assert (0 < 1 < 2)%Z as H3 by omega.
  pose proof (Zdiv_le_compat_l _ _ _ H2 H3) as H4.
  rewrite Z.div_1_r in H4.
  assumption.

  omega.

  omega.

  rewrite <- (Z.mul_1_l m) in H2 at 1.
  rewrite (Z.div_add z 1%Z m) in H2.
  omega.
  omega.

  rewrite H'.
  rewrite Z.mul_comm.
  rewrite <- Z.opp_eq_mul_m1.
  rewrite Z.opp_involutive.
  reflexivity.
Qed.

Lemma technical_2 :
  forall z m : Z,
  (- (m / 2) <= z)%Z ->
  (z + m >= m / 2)%Z.
Proof.
  intros.

  apply Z.le_ge.

  pose proof (Z.add_le_mono_r (-(m/2))%Z z m) as H0.
  apply H0 in H.
  clear H0.

  pose proof (Z.add_opp_l m (m/2)%Z) as H0.
  rewrite H0 in H.
  clear H0.

  assert ((m - (m / 2)) >= (m / 2))%Z.
  apply Z.le_ge.
  pose proof (Z.add_le_mono_r (m/2) (m - (m/2)) (m/2)) as H0.
  apply <- H0.
  clear H0.

  rewrite Z.sub_add.

  Lemma x_plus_x :
    forall x : Z, eq (x + x)%Z (2 * x)%Z.
  Proof.
    intro.
    omega.
  Qed.

  rewrite x_plus_x.
  rewrite (Z.mul_div_le m 2) by omega.
  omega.

  apply Z.ge_le in H0.
  apply (Z.le_trans _ _ _ H0 H).
Qed.

Lemma signed_repr_inverse :
  forall (w : nat) (z : Z), ((- Integers.Int.half_modulus w) <= z < (Integers.Int.half_modulus w))%Z -> eq z (Integers.Int.signed w (Integers.Int.repr w z)).
Proof.
  intros.
  unfold Integers.Int.repr, Integers.Int.signed, Integers.Int.half_modulus in *.
  simpl.
  pose proof (Integers.Int.modulus_pos w) as H99.
  remember (Integers.Int.modulus w) as m in *.
  decompose [and] H. clear H.
  destruct (Z.ltb z 0) eqn:Heqb.

  (* case 1: z < 0 *)
  clear H1.
  apply Z.ltb_lt in Heqb.
  assert (eq (z mod m)%Z (z + m)%Z) by (apply technical_1; assumption).
  rewrite H.
  assert ((z + m) >= (m / 2))%Z by (apply technical_2; assumption).
  destruct Coqlib.zlt.
  contradiction.
  omega.

  (* case 2: z >= 0 *)
  clear H0.
  apply ltb_false_geb_true in Heqb.
  apply Z.geb_le in Heqb.

  assert (Z.lt z m).
  assert (m / 2 < m)%Z by (apply Z_div_lt; omega).
  eauto using Z.lt_trans.

  pose proof (Zmod_small z m) as H4.
  pose proof (conj Heqb H) as H2.
  apply H4 in H2.
  rewrite H2.

  destruct Coqlib.zlt.
  trivial.
  contradiction.
Qed.

(*
*** Local Variables: ***
*** coq-prog-name: "coqtop" ***
*** coq-prog-args: ("-emacs-U" "-require" "coqharness" "-impredicative-set" "-R" "." "Tvc" "-R" "../../csem/_coq" "Csem" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/ott" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/monads" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/compcert" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/GraphBasics" "-I" "../../vellvm-coq84pl2/release/vol/src/Vellvm/Dominators" "-I" "../../vellvm-coq84pl2/release/vol/extralibs/metatheory_8.4" "-I" "../../vellvm-coq84pl2/release/vol/extralibs/Coq-Equations/src" "-R" "../../vellvm-coq84pl2/release/vol/extralibs/Coq-Equations/theories" "Equations" "-I" "~/lem/coq-lib") ***
*** End: ***
*)