Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith.
Require Coq.Vectors.Vector.
Global Set Asymmetric Patterns.

(* Typeclasses for ensuring that a string is included
   in a list (i.e. a set of method names). This allows
   us to omit a default case (method not found) for method
   lookups. *)

Section BoundedIndex.

  Context {A : Type}.

  Class IndexBound n
        (a : A)
        (Bound : Vector.t A n)
    :=
      { ibound : Fin.t n;
        boundi : Vector.nth Bound ibound = a
      }.

  Global Arguments ibound {n a Bound} IndexBound.
  Global Arguments IndexBound {n} a Bound.

  Record BoundedIndex
         (n : nat)
         (Bound : Vector.t A n) :=
    { bindex : A;
      indexb : IndexBound bindex Bound
    }.

  Import Vectors.VectorDef.VectorNotations.

  Definition BoundedIndex_nil
             (AnyT : Type)
             (idx : BoundedIndex 0 [])
  : AnyT.
  Proof.
    destruct idx as [idx [n] nth_n].
    inversion n.
  Qed.

  Global Arguments indexb {n Bound} b.
  Global Arguments bindex {n Bound} b.
  Global Arguments BoundedIndex {n} Bound%vector_scope.

  Lemma indexb_ibound_eq :
    forall n Bound (bidx bidx' : BoundedIndex (n := n) Bound),
      ibound (indexb bidx) = ibound (indexb bidx') ->
      bindex bidx = bindex bidx'.
  Proof.
    intros; induction Bound; simpl in *.
    - apply BoundedIndex_nil; auto.
    - destruct bidx as [bindex [n'] nth_n];
      destruct bidx' as [bindex' [n''] nth_n']; simpl in *; subst.
      congruence.
  Qed.

  Section Bounded_Index_Dec_Eq.
  (* If equality on A is decideable, so is equality
     on bounded indices in A. *)
    Variable A_eq_dec :
      forall a a' : A, {a = a'} + {a <> a'}.

    Require Import Coq.Logic.Eqdep_dec.

    Program Definition Opt_A_eq_dec (a a' : option A) :
      {a = a'} + {a <> a'} :=
      match a as a, a' as a' return {a = a'} + {a <> a'} with
          | Some a, Some a' => if A_eq_dec a a' then left _ else right _
          | None, None => left _
          | _, _ => right _
      end.

    (*Definition K_Opt_A :
      forall (a : option A) (P: a = a -> Prop),
          P (refl_equal a) -> forall p : a = a, P p :=
      K_dec_set Opt_A_eq_dec.

    Definition UIP_Opt_A  :
      forall (a : option A) (Q : option A -> Type)
             (x : Q a) (h : a = a),
        x = eq_rect a Q x a h.
      intros; eapply K_Opt_A with (p := h); reflexivity.
    Defined.

    Lemma eq_proofs_unicity_Opt_A
      : forall (a a' : option A) (p1 p2 : a = a'), p1 = p2.
      apply eq_proofs_unicity; intros.
      destruct (Opt_A_eq_dec x y); auto.
    Defined. *)

    Corollary idx_ibound_eq
    : forall n Bound (idx idx' : BoundedIndex (n := n) Bound),
        ibound (indexb idx) = ibound (indexb idx') ->
        idx = idx'.
    Proof.
      intros; generalize (indexb_ibound_eq _ _ idx idx' H);
      destruct idx as [idx [n'] In_n'];
        destruct idx' as [idx' [n''] In_n'' ]; intros;
        simpl in *; subst; f_equal.
    Qed.

    Corollary idx_ibound_neq
    : forall n Bound (idx idx' : BoundedIndex (n := n) Bound),
        ibound (indexb idx) <> ibound (indexb idx') ->
        idx <> idx'.
    Proof.
      intros; destruct idx as [idx [n'] In_n' ];
        destruct idx' as [idx' [n''] In_n'' ]; intros;
        simpl in *; subst.
      unfold not; intros; apply H; injection H0; auto.
    Qed.

    Definition fin_eq_dec {m} (n n' : Fin.t m)
      : {n = n'} + {n <> n'}.
    Proof.
      eapply Fin.rect2 with (P := fun m (n n' : Fin.t m)
                                  => {n = n'} + {n <> n'}).
      - left; reflexivity.
      - right; intro; discriminate.
      - right; intro; discriminate.
      - destruct 1; subst.
        + left; reflexivity.
        + right; intro H; apply Fin.FS_inj in H; eauto.
    Defined.

    Corollary BoundedIndex_eq_dec n Bound :
      forall idx idx' : BoundedIndex (n := n) Bound,
        {idx = idx'} + {idx <> idx'}.
    Proof.
      intros; destruct (fin_eq_dec (ibound (indexb idx)) (ibound (indexb idx'))).
      - left; auto using idx_ibound_eq.
      - right; auto using idx_ibound_neq.
    Defined.

    Fixpoint fin_beq {m n} (p : Fin.t m) (q : Fin.t n) :=
      match p, q with
      | @Fin.F1 m', @Fin.F1 n' => EqNat.beq_nat m' n'
      | Fin.FS _ _, Fin.F1 _ => false
      | Fin.F1 _, Fin.FS _ _ => false
      | Fin.FS _ p', Fin.FS _ q' => fin_beq p' q'
      end.

    Lemma fin_beq_dec {n}
      : forall (p : Fin.t n) (q : Fin.t n),
        fin_beq p q = true <-> p = q.
    Proof.
      intros; pattern n, p, q; eapply Fin.rect2; simpl;
        intuition; try (congruence || discriminate).
      - symmetry; eapply beq_nat_refl.
      - eauto using Fin.FS_inj.
    Qed.

    Corollary fin_beq_neq_dec {n}
      : forall (p : Fin.t n) (q : Fin.t n),
        fin_beq p q = false <-> p <> q.
    Proof.
      intros; setoid_rewrite <- fin_beq_dec; split;
        intros; destruct (fin_beq p q); congruence.
    Qed.

    Corollary fin_beq_refl {m}
      : forall (p : Fin.t m),
        fin_beq p p = true.
    Proof.
      intros; eapply fin_beq_dec; reflexivity.
    Qed.

    Corollary fin_beq_sym {n}
      : forall (p : Fin.t n) (q : Fin.t n),
        fin_beq p q = fin_beq q p.
    Proof.
      intros; case_eq (fin_beq p q); case_eq (fin_beq q p);
        intros; eauto.
      - apply fin_beq_neq_dec in H; apply fin_beq_dec in H0;
          congruence.
      - apply fin_beq_neq_dec in H0; apply fin_beq_dec in H;
          congruence.
    Qed.

    Corollary fin_beq_trans {n}
      : forall (p q r : Fin.t n),
        fin_beq p q = true ->
        fin_beq q r = true ->
        fin_beq p q = true.
    Proof.
      repeat setoid_rewrite fin_beq_dec; congruence.
    Qed.

    Definition BoundedIndex_beq {n Bound}
               (idx idx' : BoundedIndex (n := n) Bound)
      : bool := fin_beq (ibound (indexb idx)) (ibound (indexb idx')).

    Corollary BoundedIndex_beq_dec {n Bound}
      : forall (idx idx' : BoundedIndex (n := n) Bound),
        BoundedIndex_beq idx idx' = true <-> idx = idx'.
    Proof.
      intros; setoid_rewrite fin_beq_dec; split; intros.
      - eauto using idx_ibound_eq.
      - subst; reflexivity.
    Qed.

    Corollary BoundedIndex_beq_neq_dec {n Bound}
      : forall (idx idx' : BoundedIndex (n := n) Bound),
        BoundedIndex_beq idx idx' = false <-> idx <> idx'.
    Proof.
      intros; setoid_rewrite <- BoundedIndex_beq_dec; split;
        intros; destruct (BoundedIndex_beq idx idx'); congruence.
    Qed.

    Corollary BoundedIndex_beq_refl {m Bound}
      : forall (p : BoundedIndex (n := m) Bound),
        BoundedIndex_beq p p = true.
    Proof.
      intros; eapply BoundedIndex_beq_dec; reflexivity.
    Qed.

    Corollary BoundedIndex_beq_sym {n Bound}
      : forall (p q : BoundedIndex (n := n) Bound),
        BoundedIndex_beq p q = BoundedIndex_beq q p.
    Proof.
      intros; case_eq (BoundedIndex_beq p q); case_eq (BoundedIndex_beq q p);
        intros; eauto.
      - apply BoundedIndex_beq_neq_dec in H; apply BoundedIndex_beq_dec in H0;
          congruence.
      - apply BoundedIndex_beq_neq_dec in H0; apply BoundedIndex_beq_dec in H;
          congruence.
    Qed.

    Corollary BoundedIndex_beq_trans {n Bound}
      : forall (p q r : BoundedIndex (n := n) Bound),
        BoundedIndex_beq p q = true ->
        BoundedIndex_beq q r = true ->
        BoundedIndex_beq p q = true.
    Proof.
      repeat setoid_rewrite BoundedIndex_beq_dec; congruence.
    Qed.

  End Bounded_Index_Dec_Eq.

End BoundedIndex.

Section BoundedIndexExtensions.
  (* Helper functions for extending the set of Bounded Indexes *)

  Lemma IndexBound_AppendR {A n m}
  : forall (Bound : Vector.t A n)
           (Bound' : Vector.t A m)
           (idx : Fin.t n),
    Vector.nth (Vector.append Bound Bound') (Fin.L m idx) =
    Vector.nth Bound idx.
  Proof.
    induction Bound; intros.
    - inversion idx.
    - revert Bound IHBound; pattern n, idx; apply Fin.caseS;
        simpl; intros; eauto.
  Qed.

  Definition BoundedIndex_injR {A n Bound m Bound'}
             (idx : BoundedIndex (A := A) (n := n) Bound)
    : BoundedIndex (n := n + m) (Vector.append Bound Bound').
    refine {| bindex := bindex idx;
              indexb :=  {| ibound := Fin.L _ (ibound (indexb idx))|}
           |}.
    (* Abstract Proof Term. *)
    abstract (rewrite <- (boundi (IndexBound := indexb idx));
              eapply IndexBound_AppendR).
  Defined.

  Lemma IndexBound_AppendL {A n m}
    : forall (Bound : Vector.t A n)
             (Bound' : Vector.t A m)
             (idx : Fin.t n),
      Vector.nth (Vector.append Bound' Bound) (Fin.R m idx) =
      Vector.nth Bound idx.
  Proof.
    induction Bound'; intros.
    - reflexivity.
    - simpl; eauto.
  Qed.

  Definition BoundedIndex_injL {A n Bound m Bound'}
             (idx : BoundedIndex (A := A) (n := n) Bound)
    : BoundedIndex (n := m + n) (Vector.append Bound' Bound).
    refine {| bindex := bindex idx;
              indexb :=  {| ibound := Fin.R _ (ibound (indexb idx))|}
           |}.
    (* Abstract Proof Term. *)
    abstract (rewrite <- (boundi (IndexBound := indexb idx));
              eapply IndexBound_AppendL).
  Defined.

End BoundedIndexExtensions.

Ltac Build_nth_IndexBound n A a As As' m :=
  match n with
  | S ?n' =>
    (let check := constr:(eq_refl : a = Vector.hd As') in (* Check if the terms match *)
     exact (@Build_IndexBound A _ a As (Fin.R m (@Fin.F1 n'))
                              (@eq_refl A a)))
      ||
      let As'' := eval simpl in (Vector.tl As') in
          Build_nth_IndexBound n' A a As As'' (S m)
  end.

Hint Extern 0 (@IndexBound ?A ?n ?a ?As) =>
let n' := eval compute in n in
    Build_nth_IndexBound n' A a As As 0 : typeclass_instances.

(*
Import Vectors.VectorDef.VectorNotations.

Fixpoint foo (n : nat) : Vector.t nat (S n) :=
  match n with
  | 0 => 0 :: []
  | S n' => (S n') * (S n') * (S n') :: (foo n')
  end.

Definition foo100 := Eval simpl in foo 20.

Definition baz := Eval simpl in 3 * 3 * 3.

Definition bar : IndexBound baz foo100.
Proof.
  Unset Ltac Debug.
  Time eauto with typeclass_instances.
Defined. *)

Definition BoundedString {n} := @BoundedIndex string n.
Definition BoundedString_eq_dec
           {n}
           {Bound}
           (bidx bidx' : BoundedString Bound)
: {bidx = bidx'} + {bidx <> bidx'} :=
  BoundedIndex_eq_dec n Bound bidx bidx'.

Notation "x ++ y" := (Vector.append x y) : vector_scope.

Notation "`` A" :=
  ({| bindex := A%string |}) (at level 0, format "`` A").

Arguments BoundedString {n} _%vector_scope.

Section ithIndexBound.

  Require Import Fiat.Common.ilist.
  Import Vectors.VectorDef.VectorNotations.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type}.

  Lemma None_neq_Some
  : forall (AnyT AnyT' : Type) (a : AnyT),
      None = Some a -> AnyT'.
  Proof.
    intros; discriminate.
  Qed.

  Definition nth_Bounded
             {n}
             (Bound : Vector.t A n)
             (idx : BoundedIndex Bound)
    : A := Vector.nth Bound (ibound (indexb idx)).

  Definition ith_Bounded
             {m}
             {B : A -> Type}
             {Bound : Vector.t A m}
             (il : ilist Bound)
             (idx : BoundedIndex Bound)
    : B (Vector.nth Bound (ibound (indexb idx))) :=
    ith il (ibound (indexb idx)) .

  Lemma ith_Bounded_imap
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist Bound),
      f _ (ith_Bounded il idx) =
      ith_Bounded (imap _ _ f Bound il) idx.
  Proof.
    unfold ith_Bounded; simpl; intros; eapply ith_imap.
  Qed.

  Definition replace_BoundedIndex
             {m}
           {B : A -> Type}
           (Bound : Vector.t A m)
           (il : ilist Bound)
           (idx : BoundedIndex Bound)
           (new_b : B (nth_Bounded idx))
  : ilist Bound :=
    replace_Index Bound il (ibound (indexb idx)) new_b.

  Lemma ith_replace_BoundIndex_neq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist Bound)
      (idx idx' : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx')),
      idx <> idx'
      -> ith_Bounded (replace_BoundedIndex il idx' new_b) idx =
         ith_Bounded il idx.
  Proof.
    unfold ith_Bounded; simpl; intros; eapply ith_replace_Index_neq.
    eauto using idx_ibound_eq.
  Qed.

  Lemma ith_replace_BoundIndex_eq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist Bound)
      (idx : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx)),
      ith_Bounded (replace_BoundedIndex il idx new_b) idx = new_b.
  Proof.
    unfold ith_Bounded; simpl; intros; eapply ith_replace_Index_eq.
  Qed.

  Lemma ilist_eq {m} {B : A -> Type}
  : forall (Bound : Vector.t A m)
           (il il' : ilist (B := B) Bound),
      (forall idx, ith_Bounded il idx = ith_Bounded il' idx) -> il = il'.
  Proof.
    induction Bound; intros.
    - rewrite (ilist_invert _ il), (ilist_invert _ il'); reflexivity.
    - destruct il; destruct il'; simpl in *.
      f_equal.
      + generalize (H {| bindex := h |});
        unfold ith_Bounded; simpl; auto.
      + apply IHBound; intros.
        exact (H {| bindex := bindex idx;
                   indexb := @Build_IndexBound
                               _
                               (S n)
                               (bindex idx)
                               (h :: Bound)
                               (Fin.FS (ibound (indexb idx)))
                               (@boundi _ _ _ _ (indexb idx))
                |}).
  Qed.

  Global Arguments imap {A B B'} f {n} {As} il.
  Global Arguments BoundedIndex_eq_dec {_ _ _} _ _.

  Lemma imap_replace_BoundedIndex
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx'', B idx'' -> B' idx'')
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist Bound)
           b,
      imap f (replace_BoundedIndex il idx b) =
      replace_BoundedIndex (imap f il) idx (f _ b).
  Proof.
    intros; apply ilist_eq; intros.
    destruct (BoundedIndex_eq_dec idx idx0); subst;
    rewrite <- ith_Bounded_imap.
    - repeat rewrite ith_replace_BoundIndex_eq; reflexivity.
    - repeat rewrite ith_replace_BoundIndex_neq; auto.
      rewrite <- ith_Bounded_imap; auto.
  Qed.

End ithIndexBound.

Section ithIndexBound2.

  Require Import Fiat.Common.ilist2.
  Import Vectors.VectorDef.VectorNotations.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type}.

  Definition ith_Bounded2
             {m}
             {B : A -> Type}
             {Bound : Vector.t A m}
             (il : ilist2 Bound)
             (idx : BoundedIndex Bound)
    : B (Vector.nth Bound (ibound (indexb idx))) :=
    ith2 il (ibound (indexb idx)) .

  Lemma ith_Bounded_imap2
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist2 Bound),
      f _ (ith_Bounded2 il idx) =
      ith_Bounded2 (imap2 _ _ f Bound il) idx.
  Proof.
    unfold ith_Bounded2; simpl; intros; eapply ith_imap2.
  Qed.

  Definition replace_BoundedIndex2
             {m}
           {B : A -> Type}
           (Bound : Vector.t A m)
           (il : ilist2 Bound)
           (idx : BoundedIndex Bound)
           (new_b : B (nth_Bounded idx))
  : ilist2 Bound :=
    replace_Index2 Bound il (ibound (indexb idx)) new_b.

  Lemma ith_replace_BoundIndex2_neq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist2 Bound)
      (idx idx' : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx')),
      idx <> idx'
      -> ith_Bounded2 (replace_BoundedIndex2 il idx' new_b) idx =
         ith_Bounded2 il idx.
  Proof.
    unfold ith_Bounded2; simpl; intros; eapply ith_replace2_Index_neq.
    eauto using idx_ibound_eq.
  Qed.

  Lemma ith_replace_BoundIndex2_eq
        {m}
        {B : A -> Type}
  : forall
      (Bound : Vector.t A m)
      (il : ilist2 Bound)
      (idx : BoundedIndex Bound)
      (new_b : B (nth_Bounded idx)),
      ith_Bounded2 (replace_BoundedIndex2 il idx new_b) idx = new_b.
  Proof.
    unfold ith_Bounded2; simpl; intros; eapply ith_replace2_Index_eq.
  Qed.

  Lemma ilist2_eq {m} {B : A -> Type}
  : forall (Bound : Vector.t A m)
           (il il' : ilist2 (B := B) Bound),
      (forall idx, ith_Bounded2 il idx = ith_Bounded2 il' idx) -> il = il'.
  Proof.
    induction Bound; intros.
    - rewrite (ilist2_invert _ il), (ilist2_invert _ il'); reflexivity.
    - destruct il; destruct il'; simpl in *.
      f_equal.
      + generalize (H {| bindex := h |});
        unfold ith_Bounded2; simpl; auto.
      + apply IHBound; intros.
        exact (H {| bindex := bindex idx;
                   indexb := @Build_IndexBound
                               _
                               (S n)
                               (bindex idx)
                               (h :: Bound)
                               (Fin.FS (ibound (indexb idx)))
                               (@boundi _ _ _ _ (indexb idx))
                |}).
  Qed.

  Global Arguments imap2 {A B B'} f {n} {As} il.

  Lemma imap_replace2_BoundedIndex
        {m}
        {B B' : A -> Type}
  : forall (f : forall idx'', B idx'' -> B' idx'')
           (Bound : Vector.t A m)
           (idx : BoundedIndex Bound)
           (il : ilist2 Bound)
           b,
      imap2 f (replace_BoundedIndex2 il idx b) =
      replace_BoundedIndex2 (imap2 f il) idx (f _ b).
  Proof.
    intros; apply ilist2_eq; intros.
    destruct (BoundedIndex_eq_dec idx idx0); subst;
    rewrite <- ith_Bounded_imap2.
    - repeat rewrite ith_replace_BoundIndex2_eq; reflexivity.
    - repeat rewrite ith_replace_BoundIndex2_neq; auto.
      rewrite <- ith_Bounded_imap2; auto.
  Qed.

End ithIndexBound2.

(*Section i2thIndexBound.

  Require Import Fiat.Common.i2list.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type} {D : Set}.
  Variable (projAD : A -> D).

  (* Given a [BoundedIndex] for a list [Bound], we can always return
     an element of a list indexed by [Bound]. *)

  Definition i2th_Bounded
          {B : A -> Type}
          {C : forall a, B a -> Type}
          {As}
          (Bs : ilist B As)
          (Cs : i2list C Bs)
          (idx : BoundedIndex (map projAD As))
  : C (nth_Bounded _ As idx) (ith_Bounded projAD Bs idx) :=
    ith_Bounded_rect projAD (fun _ _ _ => C) idx Bs
                           (i2th_error' Cs (ibound idx)).

  (*Lemma ith_Bounded_imap
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist B Bound),
      f _ (ith_Bounded il idx) =
      ith_Bounded (imap B' f il) idx.
  Proof.
    intros.
    eapply ith_Bounded_ind2 with (idx0 := idx) (il0 := il) (il' := imap B' f il).
    destruct idx as [idx [n nth_n] ]; simpl in *; subst.
    revert Bound nth_n il;
      induction n; destruct Bound; simpl; eauto;
    intros; icons_invert; simpl; auto.
  Qed. *)

  (* We can lift [C (ith_Bounded idx)] to a dependent option. *)
  Definition Some_Dep_Option_elim_P
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (Bs : ilist B As)
             (idx : BoundedIndex (map projAD As))
             (c_opt : C (nth_Bounded projAD As idx) (ith_Bounded projAD Bs idx))
  : Dep_Option_elim_P C (ith_error Bs (ibound idx)) :=
    match (nth_error As (ibound idx)) as e return
          forall nth_n
                 (b : B (@nth_Bounded' _ _ _ _ _ e nth_n))
                 b_opt,
            ith_error_eq_P projAD As idx
                           b_opt
                           nth_n
                           b
            -> C _ b
            -> Dep_Option_elim_P C (a_opt := e) b_opt with
      | Some a => fun nth_n b b_opt b_eq c =>
                    match b_eq in _ = b'
                          return C _ b' -> _ with
                      | eq_refl => fun c => c
                    end c
      | None => fun nth_n b b_opt b_eq c => I
    end (nth_error_map _ _ _ (boundi idx))
        _ _ (ith_error_eq _ _ _) c_opt.

  Definition replace_BoundedIndex2
           {B : A -> Type}
           {C : forall a, B a -> Type}
           {As}
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (idx : BoundedIndex (map projAD As))
           (new_c : C _ (ith_Bounded projAD Bs idx))
  : i2list C Bs :=
    replace_Index2' (ibound idx) Cs
                   (Some_Dep_Option_elim_P Bs idx new_c).

  Definition Dep_Option_elim2_P2
             {B : A -> Type}
             {C C' : forall a, B a -> Type}
             (P : forall a b, C a b -> C' a b -> Prop)
             (a_opt : option A)
    := match a_opt return
             forall (b : Dep_Option B a_opt),
               Dep_Option_elim_P C (a_opt := a_opt) b
               -> Dep_Option_elim_P C' (a_opt := a_opt) b -> Prop with
         | Some a => fun b => P a (Dep_Option_elim b)
         | None => fun _ _ _ => True
       end .

  Lemma Dep_Option_elim2_P2_refl
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall a_opt b_opt c_opt,
      Dep_Option_elim2_P2 (fun (a : A) (b : B a) (c c' : C a b) => c = c')
                          (a_opt := a_opt) b_opt c_opt c_opt.
    unfold Dep_Option_elim2_P2; destruct a_opt; eauto.
  Qed.

  Definition i2th_error_eq_P
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (idx : BoundedIndex (map projAD As))
             (a_opt : option A)
             (b_opt : Dep_Option B a_opt)
             (c_opt : Dep_Option_elim_P C b_opt)
             (e_eq : option_map projAD a_opt = Some (bindex idx))
             (c_opt' : C (nth_Bounded' projAD As a_opt e_eq)
                         (ith_Bounded' projAD As e_eq b_opt))
  : Type :=
      match a_opt as a_opt'
        return
        forall (b_opt : Dep_Option B a_opt')
               (e_eq : option_map projAD a_opt' = Some (bindex idx)),
          Dep_Option_elim_P C b_opt ->
          C (nth_Bounded' projAD As a_opt' e_eq)
            (ith_Bounded' projAD As e_eq b_opt)
          -> Type
      with
        | Some a =>
          fun b_opt e_eq c_opt c_opt' => c_opt = c_opt'
        | None => fun b_opt e_eq c_opt c_opt' => True
      end b_opt e_eq c_opt c_opt'.

    Lemma ilist_invert' {B} (As : list A) (il : ilist B As) :
      match As as As' return ilist B As' -> Type with
        | a :: As' => fun il => { b : _ & {il' : _ & il = icons a b il'}}
        | nil => fun il => il = inil _
      end il.
    Proof.
      destruct il; eauto.
    Qed.

    Lemma i2th_error_eq
          {B : A -> Type}
          {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist B As)
             (Cs : i2list C Bs),
        i2th_error_eq_P As idx
        (ith_error Bs (ibound idx))
        (i2th_error' Cs (ibound idx))
        (nth_error_map _ _ _ (boundi idx))
        (i2th_Bounded Cs idx).
    Proof.
      unfold i2th_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Cs; simpl; eauto.
      intros; generalize (IHn As idx In_n (ilist_tl Bs) Cs); intro H';
      unfold i2th_Bounded, ith_Bounded_rect; simpl; eauto.
    Qed.

    Definition i2th_error_eq'
               {B : A -> Type}
               {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist B As)
             (c : C (nth_Bounded _ As idx) (ith_Bounded _ Bs idx)),
        i2th_error_eq_P As idx (ith_error Bs (ibound idx))
                        (Some_Dep_Option_elim_P Bs idx c)
                        (nth_error_map projAD (ibound idx) As (boundi idx)) c.
    Proof.
      unfold i2th_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Bs; simpl; eauto.
      generalize (IHn As idx In_n Bs);
      unfold i2th_Bounded, ith_Bounded_rect; simpl; eauto.
    Qed.

    Program Definition i2th_Bounded_ind
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist B As) (Cs : i2list C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
    : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (c : C' (nth_Bounded _ As idx) (ith_Bounded _ Bs idx)),
        Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith_error Bs (ibound idx))
                          (i2th_error' Cs (ibound idx))
                          (Some_Dep_Option_elim_P Bs idx c)
        -> P As Bs Cs idx _ (ith_Bounded _ Bs idx) (i2th_Bounded Cs idx) c
      := fun As idx Bs Cs c H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith_Bounded' projAD As e_eq b_opt)),
                 i2th_error_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith_error Bs (ibound idx))
             (i2th_error' Cs (ibound idx))
             (Some_Dep_Option_elim_P _ _ c)
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error_eq _ _) (i2th_error_eq' _ _ _) H.

    Program Definition i2th_Bounded_ind2
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist B As) (Cs : i2list C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
  : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (Cs' : i2list C' Bs),
      Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith_error Bs (ibound idx))
                          (i2th_error' Cs (ibound idx))
                          (i2th_error' Cs' (ibound idx))
      -> P As Bs Cs idx _ (ith_Bounded _ Bs idx)
           (i2th_Bounded Cs idx)
           (i2th_Bounded Cs' idx)
      := fun As idx Bs Cs Cs' H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith_Bounded' projAD As e_eq b_opt)),
                 i2th_error_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith_error Bs (ibound idx))
             (i2th_error' Cs (ibound idx))
             (i2th_error' Cs' (ibound idx))
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error_eq _ _) (i2th_error_eq _ _) H.

    Definition Dep_Option_elim2_T2
             {B : A -> Type}
             {C C' : forall a, B a -> Type}
             (P : forall a b, C a b -> C' a b -> Type)
             (a_opt : option A)
    := match a_opt return
             forall (b : Dep_Option B a_opt),
               Dep_Option_elim_P C (a_opt := a_opt) b
               -> Dep_Option_elim_P C' (a_opt := a_opt) b -> Type with
         | Some a => fun b => P a (Dep_Option_elim b)
         | None => fun _ _ _ => True
       end .

    Program Definition i2th_Bounded_rect
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist B As) (Cs : i2list C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Type)
    : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist B As)
           (Cs : i2list C Bs)
           (c : C' (nth_Bounded _ As idx) (ith_Bounded _ Bs idx)),
        Dep_Option_elim2_T2 (P As Bs Cs idx)
                          (ith_error Bs (ibound idx))
                          (i2th_error' Cs (ibound idx))
                          (Some_Dep_Option_elim_P Bs idx c)
        -> P As Bs Cs idx _ (ith_Bounded _ Bs idx) (i2th_Bounded Cs idx) c
      := fun As idx Bs Cs c H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith_Bounded' projAD As e_eq b_opt)),
                 i2th_error_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_T2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith_error Bs (ibound idx))
             (i2th_error' Cs (ibound idx))
             (Some_Dep_Option_elim_P _ _ c)
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error_eq _ _) (i2th_error_eq' _ _ _) H.

  Variable D_eq_dec : forall d d' : D, {d = d'} + {d <> d'}.

  Lemma i2th_replace_BoundIndex_neq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist B As)
      (Cs : i2list C Bs)
      (idx idx' : BoundedIndex (map projAD As))
      (new_c : C _ (ith_Bounded projAD Bs idx')),
      idx <> idx'
      -> i2th_Bounded (replace_BoundedIndex2 Cs idx' new_c) idx =
         i2th_Bounded Cs idx.
  Proof.
    intros.
    eapply (i2th_Bounded_ind2
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace_BoundedIndex2.
    rewrite i2th_replace_Index'_neq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed.

  Lemma i2th_replace_BoundIndex_eq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist B As)
      (Cs : i2list C Bs)
      (idx : BoundedIndex (map projAD As))
      (new_c : C _ (ith_Bounded projAD Bs idx)),
      i2th_Bounded (replace_BoundedIndex2 Cs idx new_c) idx =
      new_c.
  Proof.
    intros.
    eapply (i2th_Bounded_ind
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace_BoundedIndex2.
    rewrite i2th_replace_Index'_eq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed.

End i2thIndexBound.

Section ith2IndexBound.

  Require Import Fiat.Common.ilist2.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type} {C : Set}.
  Variable (projAC : A -> C).

  (* Given a [BoundedIndex] for a list [Bound], we can always return
     an element of a list indexed by [Bound]. *)

  Definition ith2_Bounded'
          {B : A -> Type}
          (As : list A)
          (d : C)
          (a_opt : option A)
  : forall (nth_n : option_map projAC a_opt = Some d),
      Dep_Option B a_opt
      -> B (nth_Bounded' projAC As a_opt nth_n) :=
    match a_opt as a'
          return
          forall (f : option_map projAC a' = Some d),
            Dep_Option B a' ->
            B (nth_Bounded' projAC As _ f) with
      | Some a => fun nth_n b => Dep_Option_elim b
      | None => fun nth_n b => None_neq_Some _ nth_n
    end.

  Definition ith2_Bounded
          {B : A -> Type}
          {Bound}
          (il : ilist2 B Bound)
          (idx : BoundedIndex (map projAC Bound))
  : B (nth_Bounded projAC Bound idx) :=
    ith2_Bounded' Bound (nth_error_map _ _ _ (boundi idx))
                 (ith2_error il (ibound idx)).

  (*match (nth_error Bound (ibound idx)) as a'
                  return
                  Dep_Option B a' ->
                  forall (f : option_map _ a' = Some (bindex idx)),
                    B (nth_Bounded' Bound _ f) with
        | Some a => fun b _ => Dep_Option_elim b
        | None => fun _ f => None_neq_Some _ f
    end (ith2_error il (ibound idx)) (nth_error_map _ _ (boundi idx)). *)

  (* To build a reasoning principle for ith2_Bounded, we need to
     show that option types are shuffled around by [Dep_Option_elim] *)
    Definition ith2_error_eq_P
               {B : A -> Type}
               (Bound : list A)
               (idx : BoundedIndex (map projAC Bound))
               e' b c d :=
      match e' as e'
        return
        (Dep_Option B e' ->
         forall c : option_map _ e' = Some (bindex idx),
           B (nth_Bounded' projAC Bound _ c) -> Type)
      with
        | Some e =>
          fun b c d => Dep_Option_elim b = d
        | None => fun b c d => True
      end b c d.

    Lemma ith2_error_eq
          {B : A -> Type}
    : forall (Bound : list A)
             (idx : BoundedIndex (map projAC Bound))
              (il : ilist2 B Bound),
        ith2_error_eq_P Bound idx
        (ith2_error il (ibound idx))
        (nth_error_map _ _ _ (boundi idx))
        (ith2_Bounded il idx).
    Proof.
      unfold ith2_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert n In_n; induction Bound; destruct n;
      simpl; eauto; intros.
      eapply IHBound.
    Defined.

    (* [ith2_Bounded_rect] builds a function whose type depends
     on [ith2_Bounded] by reducing to a case with [ith2_error],
     which is easier to work/reason with. *)

    Definition ith2_Bounded_rect
            {B : A -> Type}
        (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As -> forall a : A, B a -> Type)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound),
      Dep_Option_elim_P (P Bound idx il) (ith2_error il (ibound idx))
      -> P Bound idx il _ (ith2_Bounded il idx) :=
      fun Bound idx il =>
                match (nth_error Bound (ibound idx)) as e
                      return
                      forall (b : Dep_Option B e)
                             (c : option_map _ e = Some (bindex idx))
                             d,
                        (ith2_error_eq_P Bound idx b c d)
                        -> Dep_Option_elim_P (P Bound idx il) b ->
                        P _ _ _ (@nth_Bounded' _ _ projAC _ _ e c) d with
                  | Some a => fun b e_eq d c_eq =>
                                match c_eq with
                                  | eq_refl => fun b_opt => b_opt
                                end
                  | None => fun _ e_eq _ _ _ => None_neq_Some _ e_eq
                end (ith2_error il (ibound idx))
                    _
                    (ith2_Bounded il idx)
                    (ith2_error_eq idx il).

    Definition ith2_Bounded_rect2
               {B B' : A -> Type}
        (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As
                        -> ilist2 B' As
                        -> forall a : A, B a -> B' a -> Type)
        (Bound : list A)
        (idx : BoundedIndex (map projAC Bound))
        (il : ilist2 B Bound)
        (il' : ilist2 B' Bound)
    : Dep_Option_elim_T2 (P Bound idx il il')
                         (ith2_error il (ibound idx))
                         (ith2_error il' (ibound idx))
      -> P Bound idx il il' _
           (ith2_Bounded il idx)
           (ith2_Bounded il' idx) :=
      match (nth_error Bound (ibound idx)) as e
                 return
                 forall (b : Dep_Option B e)
                        (b' : Dep_Option B' e)
                        (c : option_map _ e = Some (bindex idx))
                        d d',
                   (ith2_error_eq_P Bound idx b c d)
                   -> (ith2_error_eq_P Bound idx b' c d')
                   -> Dep_Option_elim_T2 (P Bound idx il il') b b' ->
                   P _ _ _ _ (@nth_Bounded' _ _ projAC _ _ _ c) d d' with
        | Some a => fun b b' e_eq d d' d_eq d'_eq =>
                      match d_eq, d'_eq with
                        | eq_refl, eq_refl => fun b_opt => b_opt
                      end
        | None => fun b b' e_eq d d' d_eq d'_eq => None_neq_Some _ e_eq
           end (ith2_error il (ibound idx))
               (ith2_error il' (ibound idx) )
               _
               (ith2_Bounded il idx)
               (ith2_Bounded il' idx)
               (ith2_error_eq idx il)
               (ith2_error_eq idx il').

    (* [ith2_Bounded_ind] builds a proof whose type depends
     on both [nth_Bounded] and an occurence of [ith2_Bounded] by reducing
     it to a case with an [ith2_error], which is easier to reason with. *)

    Program Definition ith2_Bounded_ind
            {B B' : A -> Type}
            (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As
                        -> forall a : A, B a -> B' a -> Prop)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (b : B' (nth_Bounded projAC Bound idx)),
      Dep_Option_elim_P2 (P Bound idx il) (ith2_error il (ibound idx))
                      (Some_Dep_Option projAC Bound idx b)
      -> P Bound idx il _ (ith2_Bounded il idx) b :=
      fun Bound idx il b =>
        match (nth_error Bound (ibound idx)) as e
              return
              forall (b : Dep_Option B e)
                     (b' : Dep_Option B' e)
                     (c : option_map _ e = Some (bindex idx))
                     d d',
                (ith2_error_eq_P Bound idx b c d)
                -> (ith2_error_eq_P Bound idx b' c d')
                -> Dep_Option_elim_P2 (P Bound idx il) b b' ->
                P _ _ _ (@nth_Bounded' _ _ projAC _ _ _ c) d d' with
          | Some a => _
          | None => _
        end (ith2_error il (ibound idx))
            (Some_Dep_Option projAC Bound idx b)
            _
            (ith2_Bounded il idx)
            b
            (ith2_error_eq idx il)
            _.
    Next Obligation.
      unfold ith2_error_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert n In_n b; clear.
      induction Bound; destruct n; simpl; intros; eauto.
      unfold Some_Dep_Option; simpl.
      intros; eapply IHBound.
    Qed.

    (* [ith2_Bounded_ind2] builds a proof whose type depends
     on *two* occurences of [ith2_Bounded] by reducing  it to a case
     with two [ith2_error]s, which is easier to reason with. *)

    Program Definition ith2_Bounded_ind2
            {B B' : A -> Type}
            (P : forall As, BoundedIndex (map projAC As)
                        -> ilist2 B As
                        -> forall a : A, B a -> B' a -> Prop)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (il' : ilist2 B' Bound),
      Dep_Option_elim_P2 (P Bound idx il)
                      (ith2_error il (ibound idx))
                      (ith2_error il' (ibound idx) )
      -> P Bound idx il _ (ith2_Bounded il idx) (ith2_Bounded il' idx) :=
    fun Bound idx il il' =>
      match (nth_error Bound (ibound idx)) as e
                 return
                 forall (b : Dep_Option B e)
                        (b' : Dep_Option B' e)
                        (c : option_map _ e = Some (bindex idx))
                        d d',
                   (ith2_error_eq_P Bound idx b c d)
                   -> (ith2_error_eq_P Bound idx b' c d')
                   -> Dep_Option_elim_P2 (P Bound idx il) b b' ->
                   P _ _ _ (@nth_Bounded' _ _ projAC _ _ _ c) d d' with
          | Some a => _
          | None => _
           end (ith2_error il (ibound idx))
               (ith2_error il' (ibound idx) )
               _
               (ith2_Bounded il idx)
               (ith2_Bounded il' idx)
               (ith2_error_eq idx il)
               (ith2_error_eq idx il').

    Program Definition ith2_Bounded_ind3
            {B B' B'' : A -> Type}
            (P : forall As,
                   BoundedIndex (map projAC As)
                   -> ilist2 B As
                   -> ilist2 B' As
                   -> ilist2 B'' As
                   -> forall a : A,
                        B a -> B' a -> B'' a -> Prop)
  : forall (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (il' : ilist2 B' Bound)
           (il'' : ilist2 B'' Bound),
      Dep_Option_elim_P3 (P Bound idx il il' il'')
                      (ith2_error il (ibound idx))
                      (ith2_error il' (ibound idx))
                      (ith2_error il'' (ibound idx))
      -> P Bound idx il il' il'' _
           (ith2_Bounded il idx)
           (ith2_Bounded il' idx)
           (ith2_Bounded il'' idx) :=
    fun Bound idx il il' il'' =>
      match (nth_error Bound (ibound idx)) as e
                 return
                 forall (b : Dep_Option B e)
                        (b' : Dep_Option B' e)
                        (b'' : Dep_Option B'' e)
                        (c : option_map _ e = Some (bindex idx))
                        d d' d'',
                   (ith2_error_eq_P Bound idx b c d)
                   -> (ith2_error_eq_P Bound idx b' c d')
                   -> (ith2_error_eq_P Bound idx b'' c d'')
                   -> Dep_Option_elim_P3 (P Bound idx il il' il'') b b' b'' ->
                   P Bound idx il il' il''
                     (@nth_Bounded' _ _ _ _ _ _ c)
                     d d' d'' with
          | Some a => _
          | _  => _
           end (ith2_error il (ibound idx))
               (ith2_error il' (ibound idx) )
               (ith2_error il'' (ibound idx) )
               _
               (ith2_Bounded il idx)
               (ith2_Bounded il' idx)
               (ith2_Bounded il'' idx)
               (ith2_error_eq idx il)
               (ith2_error_eq idx il')
               (ith2_error_eq idx il'').

  Lemma ith2_Bounded_imap
        {B B' : A -> Type}
  : forall (f : forall idx, B idx -> B' idx)
           (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound),
      f _ (ith2_Bounded il idx) =
      ith2_Bounded (imap2 B' f il) idx.
  Proof.
    intros.
    eapply ith2_Bounded_ind2 with (idx0 := idx) (il0 := il) (il' := imap2 B' f il).
    destruct idx as [idx [n nth_n] ]; simpl in *; subst.
    revert Bound nth_n il;
      induction n; destruct Bound; simpl; eauto;
    intros; icons2_invert; simpl; auto.
  Qed.

  Definition replace2_BoundedIndex
           {B : A -> Type}
           (Bound : list A)
           (il : ilist2 B Bound)
           (idx : BoundedIndex (map projAC Bound))
           (new_b : B (nth_Bounded projAC Bound idx))
  : ilist2 B Bound :=
    replace_Index2 (ibound idx) il (Dep_Option_elim (Some_Dep_Option _ _ _ new_b)).

  Variable C_eq_dec : forall c c' : C, {c = c'} + {c <> c'}.

  Lemma ith2_replace_BoundIndex_neq
        {B : A -> Type}
  : forall
      (Bound : list A)
      (il : ilist2 _ Bound)
      (idx idx' : BoundedIndex (map projAC Bound))
      (new_b : B (nth_Bounded projAC Bound idx')),
      idx <> idx'
      -> ith2_Bounded (replace2_BoundedIndex il idx' new_b) idx =
         ith2_Bounded il idx.
  Proof.
    intros.
    eapply ith2_Bounded_ind2 with (idx0 := idx) (il0 := replace2_BoundedIndex il idx' new_b)
                                                (il' := il).
    eapply ith2_replace_Index2_neq; eauto using idx_ibound_eq.
  Qed.

  Lemma ith2_replace_BoundIndex_eq
        {B : A -> Type}
  : forall
      (Bound : list A)
      (il : ilist2 _ Bound)
      (idx : BoundedIndex (map projAC Bound))
      (new_b : B (nth_Bounded projAC Bound idx)),
      ith2_Bounded (replace2_BoundedIndex il idx new_b) idx = new_b.
  Proof.
    intros.
    eapply ith2_Bounded_ind with (idx0 := idx)
                                  (il0 := replace2_BoundedIndex il idx new_b)
                                  (P := fun Bound idx il a il' b => il' = b).
    eapply ith2_replace_Index2_eq; eauto.
  Qed.

  Lemma ith2_replace_BoundedIndex_ind
        {B : A -> Type}
        (P : forall As (idx : BoundedIndex (map projAC As)),
               B (nth_Bounded projAC As idx)
               -> B (nth_Bounded projAC As idx) -> Prop)
  : forall (Bound : list A)
           (idx idx' : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           (new_b : B (nth_Bounded projAC Bound idx')),
      (forall idx :  BoundedIndex (map projAC Bound),
         ibound idx <> ibound idx'
         -> P _ idx (ith2_Bounded il idx)
              (ith2_Bounded il idx))
      -> P _ idx' (ith2_Bounded il idx') new_b
      -> P _ idx
           (ith2_Bounded il idx)
           (ith2_Bounded (replace2_BoundedIndex il idx' new_b) idx).
  Proof.
    intros.
    destruct (BoundedIndex_eq_dec C_eq_dec idx idx'); subst.
    + rewrite ith2_replace_BoundIndex_eq; assumption.
    + rewrite ith2_replace_BoundIndex_neq;
      unfold not; eauto using idx_ibound_eq.
  Qed.

  Lemma ilist2_eq {B : A -> Type}
  : forall (Bound : list A)
           (il il' : ilist2 B Bound),
      (forall idx, ith2_Bounded il idx = ith2_Bounded il' idx) -> il = il'.
  Proof.
    induction Bound; intros.
    - rewrite (ilist2_invert il), (ilist2_invert il'); reflexivity.
    - icons2_invert; f_equal.
      generalize (H {| bindex := projAC a;
                       indexb := IndexBound_head _ _  |}).
      unfold ith2_Bounded; simpl; auto.
      apply IHBound; intros.
      generalize (H  {| bindex := bindex idx;
                       indexb := @IndexBound_tail _ _ _ _ (indexb idx) |}).
      unfold ith2_Bounded; simpl; auto.
  Qed.

  Lemma imap2_replace2_BoundedIndex
        {B B' : A -> Type}
  : forall (f : forall idx'', B idx'' -> B' idx'')
           (Bound : list A)
           (idx : BoundedIndex (map projAC Bound))
           (il : ilist2 B Bound)
           b,
      imap2 B' f (replace2_BoundedIndex il idx b) =
      replace2_BoundedIndex (imap2 B' f il) idx (f _ b).
  Proof.
    intros; apply ilist2_eq; intros.
    destruct (BoundedIndex_eq_dec C_eq_dec idx idx0); subst;
    rewrite <- ith2_Bounded_imap.
    - repeat rewrite ith2_replace_BoundIndex_eq; reflexivity.
    - repeat rewrite ith2_replace_BoundIndex_neq; auto.
      rewrite <- ith2_Bounded_imap; auto.
  Qed.

End ith2IndexBound.

Section i2th2IndexBound.

  Require Import Fiat.Common.i2list2.

  (* Given a bounded index [BoundedIndex Bound], we can wrap
     various lookup functions over lists indexed over [Bound].
   *)

  Context {A : Type} {D : Set}.
  Variable (projAD : A -> D).

  (* Given a [BoundedIndex] for a list [Bound], we can always return
     an element of a list indexed by [Bound]. *)

  Definition i2th2_Bounded
          {B B' : A -> Type}
          {C : forall a, B a -> B' a -> Type}
          {As}
          (Bs : ilist B As)
          (Bs' : ilist B' As)
          (Cs : i2list2 C Bs Bs')
          (idx : BoundedIndex (map projAD As))
  : C (nth_Bounded _ As idx)
      (ith_Bounded projAD Bs idx)
      (ith_Bounded projAD Bs' idx) :=
    ith_Bounded_rect2 projAD (fun _ _ _ _ => C) idx Bs Bs'
                       (i2th_error2' Cs (ibound idx)).

  (*Definition Some_Dep_Option_elim_P2
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (Bs : ilist2 B As)
             (idx : BoundedIndex (map projAD As))
             (c_opt : C (nth_Bounded projAD As idx) (ith2_Bounded projAD Bs idx))
  : Dep_Option_elim_P C (ith2_error Bs (ibound idx)) :=
    match (nth_error As (ibound idx)) as e return
          forall nth_n
                 (b : B (@nth_Bounded' _ _ _ _ _ e nth_n))
                 b_opt,
            ith_error_eq_P projAD As idx
                           b_opt
                           nth_n
                           b
            -> C _ b
            -> Dep_Option_elim_P C (a_opt := e) b_opt with
      | Some a => fun nth_n b b_opt b_eq c =>
                    match b_eq in _ = b'
                          return C _ b' -> _ with
                      | eq_refl => fun c => c
                    end c
      | None => fun nth_n b b_opt b_eq c => I
    end (nth_error_map _ _ _ (boundi idx))
        _ _ (ith2_error_eq _ _ _) c_opt.

  Definition replace2_BoundedIndex2
           {B : A -> Type}
           {C : forall a, B a -> Type}
           {As}
           (Bs : ilist2 B As)
           (Cs : i2list2 C Bs)
           (idx : BoundedIndex (map projAD As))
           (new_c : C _ (ith2_Bounded projAD Bs idx))
  : i2list2 C Bs :=
    replace_2Index2' (ibound idx) Cs
                   (Some_Dep_Option_elim_P2 Bs idx new_c).

  Definition Dep_Option_2elim2_P2
             {B : A -> Type}
             {C C' : forall a, B a -> Type}
             (P : forall a b, C a b -> C' a b -> Prop)
             (a_opt : option A)
    := match a_opt return
             forall (b : Dep_Option B a_opt),
               Dep_Option_elim_P C (a_opt := a_opt) b
               -> Dep_Option_elim_P C' (a_opt := a_opt) b -> Prop with
         | Some a => fun b => P a (Dep_Option_elim b)
         | None => fun _ _ _ => True
       end .

  Lemma Dep_Option_2elim2_P2_refl
        {B : A -> Type}
        {C C' : forall a, B a -> Type}
  : forall a_opt b_opt c_opt,
      Dep_Option_2elim2_P2 (fun (a : A) (b : B a) (c c' : C a b) => c = c')
                          (a_opt := a_opt) b_opt c_opt c_opt.
    unfold Dep_Option_2elim2_P2; destruct a_opt; eauto.
  Qed.

  Definition i2th_error2_eq_P
             {B : A -> Type}
             {C : forall a, B a -> Type}
             (As : list A)
             (idx : BoundedIndex (map projAD As))
             (a_opt : option A)
             (b_opt : Dep_Option B a_opt)
             (c_opt : Dep_Option_elim_P C b_opt)
             (e_eq : option_map projAD a_opt = Some (bindex idx))
             (c_opt' : C (nth_Bounded' projAD As a_opt e_eq)
                         (ith2_Bounded' projAD As e_eq b_opt))
  : Type :=
      match a_opt as a_opt'
        return
        forall (b_opt : Dep_Option B a_opt')
               (e_eq : option_map projAD a_opt' = Some (bindex idx)),
          Dep_Option_elim_P C b_opt ->
          C (nth_Bounded' projAD As a_opt' e_eq)
            (ith2_Bounded' projAD As e_eq b_opt)
          -> Type
      with
        | Some a =>
          fun b_opt e_eq c_opt c_opt' => c_opt = c_opt'
        | None => fun b_opt e_eq c_opt c_opt' => True
      end b_opt e_eq c_opt c_opt'.

    Lemma i2th_error2_eq
          {B : A -> Type}
          {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist2 B As)
             (Cs : i2list2 C Bs),
        i2th_error2_eq_P As idx
        (ith2_error Bs (ibound idx))
        (i2th_error2' Cs (ibound idx))
        (nth_error_map _ _ _ (boundi idx))
        (i2th2_Bounded Cs idx).
    Proof.
      unfold i2th_error2_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Cs; simpl; eauto.
      intros; generalize (IHn As idx In_n (ilist2_tl Bs) Cs); intro H';
      unfold i2th_Bounded, ith2_Bounded_rect; simpl; eauto.
    Qed.

    Definition i2th_error2_eq'
               {B : A -> Type}
               {C : forall a, B a -> Type}
    : forall (As : list A)
             (idx : BoundedIndex (map projAD As))
             (Bs : ilist2 B As)
             (c : C (nth_Bounded _ As idx) (ith2_Bounded _ Bs idx)),
        i2th_error2_eq_P As idx (ith2_error Bs (ibound idx))
                        (Some_Dep_Option_elim_P2 Bs idx c)
                        (nth_error_map projAD (ibound idx) As (boundi idx)) c.
    Proof.
      unfold i2th_error2_eq_P; simpl.
      destruct idx as [idx [n In_n ]]; simpl in *.
      revert As idx In_n.
      induction n; destruct Bs; simpl; eauto.
      generalize (IHn As idx In_n Bs);
      unfold i2th_Bounded, ith2_Bounded_rect; simpl; eauto.
    Qed.

    Program Definition i2th_Bounded2_ind
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist2 B As) (Cs : i2list2 C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
    : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist2 B As)
           (Cs : i2list2 C Bs)
           (c : C' (nth_Bounded _ As idx) (ith2_Bounded _ Bs idx)),
        Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith2_error Bs (ibound idx))
                          (i2th_error2' Cs (ibound idx))
                          (Some_Dep_Option_elim_P2 Bs idx c)
        -> P As Bs Cs idx _ (ith2_Bounded _ Bs idx) (i2th2_Bounded Cs idx) c
      := fun As idx Bs Cs c H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith2_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith2_Bounded' projAD As e_eq b_opt)),
                 i2th_error2_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error2_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith2_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith2_error Bs (ibound idx))
             (i2th_error2' Cs (ibound idx))
             (Some_Dep_Option_elim_P2 _ _ c)
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error2_eq _ _) (i2th_error2_eq' _ _ _) H.

    Program Definition i2th_Bounded2_ind2
            {B : A -> Type}
            {C C' : forall a, B a -> Type}
            (P : forall As (Bs : ilist2 B As) (Cs : i2list2 C Bs),
                   BoundedIndex (map projAD As)
                   -> forall (a : A) (b : B a), C a b -> C' a b -> Prop)
  : forall (As : list A)
           (idx : BoundedIndex (map projAD As))
           (Bs : ilist2 B As)
           (Cs : i2list2 C Bs)
           (Cs' : i2list2 C' Bs),
      Dep_Option_elim2_P2 (P As Bs Cs idx)
                          (ith2_error Bs (ibound idx))
                          (i2th_error2' Cs (ibound idx))
                          (i2th_error2' Cs' (ibound idx))
      -> P As Bs Cs idx _ (ith2_Bounded _ Bs idx)
           (i2th2_Bounded Cs idx)
           (i2th2_Bounded Cs' idx)
      := fun As idx Bs Cs Cs' H =>
         match (nth_error As (ibound idx)) as e
               return
               forall (b_opt : Dep_Option B e) (c_opt : Dep_Option_elim_P C b_opt)
                       (c'_opt : Dep_Option_elim_P C' b_opt)
                       (e_eq : option_map projAD e = Some (bindex idx))
                       (d : C (nth_Bounded' projAD As e e_eq)
                              (ith2_Bounded' projAD As e_eq b_opt))
                       (d' : C' (nth_Bounded' projAD As e e_eq)
                                (ith2_Bounded' projAD As e_eq b_opt)),
                 i2th_error2_eq_P As idx b_opt c_opt e_eq d ->
                 i2th_error2_eq_P As idx b_opt c'_opt e_eq d' ->
                 Dep_Option_elim2_P2 (P As Bs Cs idx) b_opt c_opt c'_opt ->
                  P As Bs Cs idx (nth_Bounded' projAD _ e e_eq)
                    (ith2_Bounded' projAD _ e_eq _) d d'
         with
           | Some a => fun b_opt c_opt c'_opt e_eq d d' c_eq c_eq' => _
           | None => fun b_opt c_opt c'_opt e_eq d d' => None_neq_Some _ e_eq
         end (ith2_error Bs (ibound idx))
             (i2th_error2' Cs (ibound idx))
             (i2th_error2' Cs' (ibound idx))
             (nth_error_map projAD (ibound idx) As (boundi idx))
             _ _ (i2th_error2_eq _ _) (i2th_error2_eq _ _) H.

  Variable D_eq_dec : forall d d' : D, {d = d'} + {d <> d'}.

  Lemma i2th_replace2_BoundIndex_neq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist2 B As)
      (Cs : i2list2 C Bs)
      (idx idx' : BoundedIndex (map projAD As))
      (new_c : C _ (ith2_Bounded projAD Bs idx')),
      idx <> idx'
      -> i2th2_Bounded (replace2_BoundedIndex2 Cs idx' new_c) idx =
         i2th2_Bounded Cs idx.
  Proof.
    intros.
    pose (i2th_Bounded2_ind2 (B := B) (C' := C)
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace2_BoundedIndex2.
    unfold i2th2_Bounded.
    rewrite i2th_replace_2Index2'_neq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed.

  Lemma i2th_replace2_BoundIndex_eq
        {B : A -> Type}
        {C : forall a, B a -> Type}
  : forall
      {As}
      (Bs : ilist2 B As)
      (Cs : i2list2 C Bs)
      (idx : BoundedIndex (map projAD As))
      (new_c : C _ (ith2_Bounded projAD Bs idx)),
      i2th2_Bounded (replace2_BoundedIndex2 Cs idx new_c) idx =
      new_c.
  Proof.
    intros.
    eapply (i2th_Bounded2_ind
              (fun As Bs Cs idx a b c c' => c = c')).
    unfold replace2_BoundedIndex2.
    rewrite i2th_replace_2Index2'_eq; eauto using idx_ibound_eq, Dep_Option_elim2_P2_refl.
  Qed. *)

End i2th2IndexBound. *)

Ltac subst_strings :=
  repeat match goal with
           | [ H : string |- _ ] => subst H
           | [ H : BoundedIndex _ |- _ ] => subst H
         end.

Ltac pose_string_ids :=
  subst_strings;
  repeat match goal with
           | |- context [String ?R ?R'] =>
             let str := fresh "StringId" in
             set (String R R') as str in *
           (*| |- context [ ``(?R) ] =>
             let idx := fresh in
             set ``(R) as fresh in * *)
         end.

Arguments BoundedString [_] _.


From Undecidability.Synthetic Require Import Definitions EnumerabilityFacts.
From Undecidability.Synthetic Require ListEnumerabilityFacts.

Require Import Undecidability.TM.SBTM.
Import SBTMNotations.

Set Default Goal Selector "!".

(* semi-decider for SBTM_HALT *)
Lemma SBTM_HALT_semi_decision : { f : { M : SBTM & config M } -> nat -> bool | semi_decider f SBTM_HALT }.
Proof.
  exists (fun '(existT _ M x) k => match steps M k x with | Some _ => false | None => true end).
  intros [M x]. split.
  + intros [k Hk]. exists k. now rewrite Hk.
  + intros [k Hk]. exists k.
    now destruct (steps M k x) as [?|].
Qed.

Definition SBTM_to_sigT (M : SBTM) := existT
  (fun n => Vector.t (option (Fin.t n * _ * _) * option (Fin.t n * _ * _)) n) (num_states M) (trans M).
Definition SBTM_of_sigT := fun '(existT _ n t) => @Build_SBTM n t.

Lemma direction_enumeration : { e | enumerator__T e direction}.
Proof.
  exists (fun n => match n with 0 => Some go_left | _ => Some go_right end).
  now intros []; [exists 0|exists 1].
Qed.

Lemma SBTM_enumeration : { e : nat -> option SBTM | enumerator__T e SBTM }.
Proof.
  assert {f | enumerator__T f {n : nat & Vector.t
    (option (Fin.t n * bool * direction) *
    option (Fin.t n * bool * direction)) n}} as [f Hf].
  { eexists.
    eapply enumerator__T_sigT.
    - apply enumerator__T_nat.
    - intros x. apply enumerator__T_Vector.
      apply enumerator__T_prod.
      + apply enumerator__T_option.
        apply enumerator__T_prod; [apply enumerator__T_prod|].
        * apply enumerator__T_Fin.
        * apply enumerator__T_bool.
        * apply (proj2_sig direction_enumeration).
      + apply enumerator__T_option.
        apply enumerator__T_prod; [apply enumerator__T_prod|].
        * apply enumerator__T_Fin.
        * apply enumerator__T_bool.
        * apply (proj2_sig direction_enumeration). }
  exists (fun n => option_map SBTM_of_sigT (f n)).
  intros M.
  destruct (Hf (SBTM_to_sigT M)) as [n Hn].
  exists n. rewrite Hn. now destruct M.
Qed.

Lemma config_enumeration (M : SBTM) : { e : nat -> option (config M) | enumerator__T e (config M) }.
Proof.
  eexists. apply enumerator__T_prod.
  + apply enumerator__T_Fin.
  + apply enumerator__T_prod; [apply enumerator__T_prod|].
    * eapply ListEnumerabilityFacts.enumerator__T_to_list.
      eapply ListEnumerabilityFacts.enumerator__T_list.
      eapply ListEnumerabilityFacts.enumerator__T_of_list.
      apply enumerator__T_bool.
    * apply enumerator__T_bool.
    * eapply ListEnumerabilityFacts.enumerator__T_to_list.
      eapply ListEnumerabilityFacts.enumerator__T_list.
      eapply ListEnumerabilityFacts.enumerator__T_of_list.
      apply enumerator__T_bool.
Qed.

Lemma SBTM_HALT_INSTANCE_enumeration : { e | enumerator__T e {M : SBTM & config M }}.
Proof.
  eexists.
  apply enumerator__T_sigT.
  - apply (proj2_sig SBTM_enumeration).
  - intros M. apply (proj2_sig (config_enumeration M)).
Qed.

(* enumerator for SBTM_HALT *)
Lemma SBTM_HALT_enumeration : { e : nat -> option { M : SBTM & config M } | enumerator e SBTM_HALT }.
Proof.
  exact (semi_decider_enumerator
    (proj2_sig SBTM_HALT_INSTANCE_enumeration)
    (proj2_sig SBTM_HALT_semi_decision)).
Qed.

Definition SBTM_HALT_enumerator := proj1_sig SBTM_HALT_enumeration.

Lemma SBTM_HALT_enumerator_spec : enumerator SBTM_HALT_enumerator SBTM_HALT.
Proof. exact (proj2_sig SBTM_HALT_enumeration). Qed.


Require Import TestSuite.admit.
Set Implicit Arguments.
Generalizable All Variables.
Set Universe Polymorphism.

Polymorphic Record SpecializedCategory@{l k} (obj : Type@{l}) := Build_SpecializedCategory' {
  Object :> Type@{l} := obj;
  Morphism' : obj -> obj -> Type@{k};

  Identity' : forall o, Morphism' o o;
  Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d'
}.

Polymorphic Definition Morphism obj (C : @SpecializedCategory obj) : forall s d : C, _ := Eval cbv beta delta [Morphism'] in C.(Morphism').

(* eh, I'm not terribly happy.  meh. *)
Polymorphic Definition SmallSpecializedCategory (obj : Set) (*mor : obj -> obj -> Set*) := SpecializedCategory@{Set Set} obj.
Polymorphic Identity Coercion SmallSpecializedCategory_LocallySmallSpecializedCategory_Id : SmallSpecializedCategory >-> SpecializedCategory.

Polymorphic Record Category := {
  CObject : Type;

  UnderlyingCategory :> @SpecializedCategory CObject
}.

Polymorphic Definition GeneralizeCategory `(C : @SpecializedCategory obj) : Category.
  refine {| CObject := C.(Object) |}; auto.
Defined.

Polymorphic Coercion GeneralizeCategory : SpecializedCategory >-> Category.

Section SpecializedFunctor.
  Set Universe Polymorphism.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Unset Universe Polymorphism.

  Polymorphic Record SpecializedFunctor := {
    ObjectOf' : objC -> objD;
    MorphismOf' : forall s d, C.(Morphism') s d -> D.(Morphism') (ObjectOf' s) (ObjectOf' d);
    FCompositionOf' : forall s d d' (m1 : C.(Morphism') s d) (m2: C.(Morphism') d d'),
      MorphismOf' _ _ (C.(Compose') _ _ _ m2 m1) = D.(Compose') _ _ _ (MorphismOf' _ _ m2) (MorphismOf' _ _ m1);
    FIdentityOf' : forall o, MorphismOf' _ _ (C.(Identity') o) = D.(Identity') (ObjectOf' o)
  }.
End SpecializedFunctor.

Global Polymorphic Coercion ObjectOf' : SpecializedFunctor >-> Funclass.
Set Universe Polymorphism.
Section Functor.
  Variable C D : Category.

  Polymorphic Definition Functor := SpecializedFunctor C D.
End Functor.
Unset Universe Polymorphism.

Polymorphic Identity Coercion Functor_SpecializedFunctor_Id : Functor >-> SpecializedFunctor.
Polymorphic Definition GeneralizeFunctor objC C objD D (F : @SpecializedFunctor objC C objD D) : Functor C D := F.
Polymorphic Coercion GeneralizeFunctor : SpecializedFunctor >-> Functor.

Arguments SpecializedFunctor {objC} C {objD} D.

Polymorphic Record SmallCategory := {
  SObject : Set;

  SUnderlyingCategory :> @SmallSpecializedCategory SObject
}.

Polymorphic Definition GeneralizeSmallCategory `(C : @SmallSpecializedCategory obj) : SmallCategory.
  refine {| SObject := obj |}; destruct C; econstructor; eassumption.
Defined.

Polymorphic Coercion GeneralizeSmallCategory : SmallSpecializedCategory >-> SmallCategory.

Bind Scope category_scope with SmallCategory.

Polymorphic Definition TypeCat : @SpecializedCategory Type := (@Build_SpecializedCategory' Type
                                                                                (fun s d => s -> d)
                                                                                (fun _ => (fun x => x))
                                                                                (fun _ _ _ f g => (fun x => f (g x)))).
(*Unset Universe Polymorphism.*)
Polymorphic Definition FunctorCategory objC (C : @SpecializedCategory objC) objD (D : @SpecializedCategory objD) :
  @SpecializedCategory (SpecializedFunctor C D).
Admitted.

Polymorphic Definition DiscreteCategory (O : Type) : @SpecializedCategory O.
Admitted.

Polymorphic Definition ComputableCategory (I : Type) (Index2Object : I -> Type) (Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)) :
  @SpecializedCategory I.
Admitted.

Polymorphic Definition is_unique (A : Type) (x : A) := forall x' : A, x' = x.

Polymorphic Definition InitialObject obj {C : SpecializedCategory obj} (o : C) :=
    forall o', { m : C.(Morphism) o o' | is_unique m }.

Polymorphic Definition SmallCat := ComputableCategory _ SUnderlyingCategory.

Lemma InitialCategory_Initial : InitialObject (C := SmallCat) (DiscreteCategory Empty_set : SmallSpecializedCategory _).
  admit.
Qed.

Set Universe Polymorphism.
Section GraphObj.
  Context `(C : @SpecializedCategory objC).

  Inductive GraphIndex := GraphIndexSource | GraphIndexTarget.

  Definition GraphIndex_Morphism (a b : GraphIndex) : Set :=
    match (a, b) with
      | (GraphIndexSource, GraphIndexSource) => unit
      | (GraphIndexTarget, GraphIndexTarget) => unit
      | (GraphIndexTarget, GraphIndexSource) => Empty_set
      | (GraphIndexSource, GraphIndexTarget) => GraphIndex
    end.

  Global Arguments GraphIndex_Morphism a b /.

  Definition GraphIndex_Compose s d d' (m1 : GraphIndex_Morphism d d') (m2 : GraphIndex_Morphism s d) :
    GraphIndex_Morphism s d'.
  Proof using.  (* This makes no sense, but it makes this test behave as before the no admit commit *)
  Admitted.

   Definition GraphIndexingCategory : @SpecializedCategory GraphIndex.
    refine {|
      Morphism' := GraphIndex_Morphism;
      Identity' := (fun x => match x with GraphIndexSource => tt | GraphIndexTarget => tt end);
      Compose' := GraphIndex_Compose
    |};
    admit.
  Defined.

  Definition UnderlyingGraph_ObjectOf x :=
    match x with
      | GraphIndexSource => { sd : objC * objC & C.(Morphism) (fst sd) (snd sd) }
      | GraphIndexTarget => objC
    end.

  Global Arguments UnderlyingGraph_ObjectOf x /.

  Definition UnderlyingGraph_MorphismOf s d (m : Morphism GraphIndexingCategory s d) :
    UnderlyingGraph_ObjectOf s -> UnderlyingGraph_ObjectOf d.
  Admitted.

  Definition UnderlyingGraph : SpecializedFunctor GraphIndexingCategory TypeCat.
  Proof.
    match goal with
      | [ |- SpecializedFunctor ?C ?D ] =>
        refine (Build_SpecializedFunctor C D
          UnderlyingGraph_ObjectOf
          UnderlyingGraph_MorphismOf
          _
          _
        )
    end;
    admit.
  Defined.
End GraphObj.

Set Printing Universes.
Set Printing All.

Print Coercions.

Section test.

Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf' (C D : SmallCategory) (F : SpecializedFunctor C D) :
    Morphism (FunctorCategory TypeCat GraphIndexingCategory)
    (@UnderlyingGraph (SObject C)
                     (SmallSpecializedCategory_LocallySmallSpecializedCategory_Id (SUnderlyingCategory C)))
    (UnderlyingGraph D).
 (* Toplevel input, characters 216-249:
Error:
In environment
C : SmallCategory (* Top.594 *)
D : SmallCategory (* Top.595 *)
F :
@SpecializedFunctor (* Top.25 Set Top.25 Set *) (SObject (* Top.25 *) C)
  (SUnderlyingCategory (* Top.25 *) C) (SObject (* Top.25 *) D)
  (SUnderlyingCategory (* Top.25 *) D)
The term
 "SUnderlyingCategory (* Top.25 *) C
  :SpecializedCategory (* Top.25 Set *) (SObject (* Top.25 *) C)" has type
 "SpecializedCategory (* Top.618 Top.619 *) (SObject (* Top.25 *) C)"
while it is expected to have type
 "SpecializedCategory (* Top.224 Top.225 *) (SObject (* Top.617 *) C)"
(Universe inconsistency: Cannot enforce Set = Top.225)).
 *)
Fail Admitted.

Fail Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) :
  Morphism (FunctorCategory TypeCat GraphIndexingCategory) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*)
Fail Admitted.

Polymorphic Definition UnderlyingGraphFunctor_MorphismOf (C D : SmallCategory) (F : SpecializedFunctor C D) :
  Morphism (FunctorCategory GraphIndexingCategory TypeCat) (UnderlyingGraph C) (UnderlyingGraph D). (* Anomaly: apply_coercion. Please report.*)
Proof.
Admitted.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Archetypal.Discr.Discr Archetypal.Discr.NatFacts.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Cat.Cat_Iso.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat.
From Categories Require Import KanExt.LocalFacts.NatIso.

From Categories Require Import Limits.Limit.
From Categories Require Import Limits.Isomorphic_Cat.

Section GenProd_Sum.
  Context {A : Type} {C : Category} (map : A → C).

  Definition GenProd := Limit (Discr_Func map).

  Identity Coercion GenProd_Limit : GenProd >-> Limit.

  Definition GenSum := CoLimit (Discr_Func_op map).

  Identity Coercion GenSum_CoLimit : GenSum >-> CoLimit.

End GenProd_Sum.

Arguments GenProd {_}%type {_}%category _, {_} _ _.
Arguments GenSum {_}%type {_}%category _, {_} _ _.

Notation "'Π' m" := (GenProd m) : object_scope.

Notation "'Σ' m" := (GenSum m) : object_scope.

Notation "'Π_' C ↓ m" := (GenProd C m) : object_scope.

Notation "'Σ_' C ↓ m" := (GenSum C m) : object_scope.

(** The fact That if a category has generalized products of some type,
    its dual also has generalized sums of that type. *)

Section GenProd_to_GenSum.
  Context {A : Type} {C : Category} {map : A → C} (L : (Π map)%object).

  Definition GenProd_to_GenSum : (Σ_ (C^op) ↓ map)%object :=
    Local_Right_KanExt_Iso ((@Discr_Func_Iso (C^op) A map)⁻¹) L.

End GenProd_to_GenSum.

(** The fact That if a category has generalized sums of some type, its dual has
generalized products of that type. *)
Section GenSum_to_GenProd.
  Context {A : Type} {C : Category} {map : A → C} (L : (Σ map)%object).

  Definition GenSum_to_GenProd : (Π_ (C^op) ↓ map)%object :=
    Local_Right_KanExt_Iso (Discr_Func_Iso map) L.

End GenSum_to_GenProd.

(** If we have GenSum for all functions from a type A, where A is isomorphic
to B we have all GenSum for all functions from B. We show this by showing
that for the underlying functor of any GenSum from B is isomorphic to the
underlying functor of some GenSum from A pre-composed with the provided
isomorphism.
*)
Section GenSum_IsoType.
  Context {A B : Type} (Iso : (A ≃≃ B ::> Type_Cat)%isomorphism) {C : Category}
          (SM : forall f : A → C, (Σ f)%object).

  Program Definition GenSum_IsoType_map_Iso (map : B → C):
    (
      ((((Discr_Func_op map)^op)%functor)
         ≃≃ ((Discr_Func_op
                (fun x : A => map ((iso_morphism Iso) x))
                ∘ (iso_morphism (Opposite_Cat_Iso
                                   (Inverse_Isomorphism
                                      (Discr_Cat_Iso Iso)))))^op
            )%functor
        ::> Func_Cat _ _)%isomorphism
    )%morphism
    :=
      {|
        iso_morphism :=
          {|
            Trans :=
              Trans
                (iso_morphism
                   (IsoCat_NatIso (Opposite_Cat_Iso
                                     (Discr_Cat_Iso Iso)) (Discr_Func_op map))
                )
          |};
        inverse_morphism :=
          {|
            Trans :=
              Trans
                (inverse_morphism
                   (IsoCat_NatIso (Opposite_Cat_Iso
                                     (Discr_Cat_Iso Iso)) (Discr_Func_op map))
                )
          |}
      |}
  .

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    apply (
        f_equal
          Trans
          (
            right_inverse
              (IsoCat_NatIso (Opposite_Cat_Iso
                                (Discr_Cat_Iso Iso)) (Discr_Func_op map))
          )
      ).
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify.
    apply (
        f_equal
          Trans
          (
            left_inverse
              (IsoCat_NatIso (Opposite_Cat_Iso
                                (Discr_Cat_Iso Iso)) (Discr_Func_op map))
          )
      ).
  Qed.

  Definition  GenSum_IsoType (map : B → C) : (Σ map)%object :=
    Local_Right_KanExt_Iso
      (GenSum_IsoType_map_Iso map)
      (
        CoLimit_From_Isomorphic_Cat
          (Opposite_Cat_Iso (Inverse_Isomorphism (Discr_Cat_Iso Iso)))
          (SM (fun x : A => map ((iso_morphism Iso) x)))
      ).

End GenSum_IsoType.


Require Import Basics.
Require Import Types.
Require Import Pointed.Core.
Require Import WildCat.

Local Open Scope pointed_scope.

(** Some higher homotopies *)

Definition phomotopy_inverse_1 {A : pType} {P : pFam A} {f : pForall A P}
  : (phomotopy_reflexive f)^* ==* phomotopy_reflexive f.
Proof.
  srapply Build_pHomotopy.
  + reflexivity.
  + pointed_reduce. reflexivity.
Defined.

(** [phomotopy_path] sends concatenation to composition of pointed homotopies.*)
Definition phomotopy_path_pp {A : pType} {P : pFam A}
  {f g h : pForall A P} (p : f = g) (q : g = h)
  : phomotopy_path (p @ q) ==* phomotopy_path p @* phomotopy_path q.
Proof.
  induction p. induction q. symmetry. apply phomotopy_compose_p1.
Defined.

(** ** Whiskering of pointed homotopies by pointed functions *)

Definition pmap_postwhisker {A B C : pType} {f g : A ->* B}
  (h : B ->* C) (p : f ==* g) : h o* f ==* h o* g.
Proof.
  snrapply Build_pHomotopy; cbn.
  1: intros a; apply ap, p.
  pointed_reduce.
  symmetry.
  simpl.
  refine (concat_p1 _ @ concat_p1 _ @ ap _ _).
  exact (concat_p1 _).
Defined.

Definition pmap_prewhisker {A B C : pType} (f : A ->* B)
  {g h : B ->* C} (p : g ==* h) : g o* f ==* h o* f.
Proof.
  snrapply Build_pHomotopy; cbn.
  1: intros a; apply p.
  pointed_reduce.
  symmetry.
  refine (concat_p1 _ @ concat_1p _ @ concat_p1 _).
Defined.

(** ** Composition of pointed homotopies *)
Definition phomotopy_path2 {A : pType} {P : pFam A}
  {f g : pForall A P} {p p' : f = g} (q : p = p')
  : phomotopy_path p ==* phomotopy_path p'.
Proof.
  induction q. reflexivity.
Defined.

(** [phomotopy_path] sends inverses to inverses.*)
Definition phomotopy_path_V {A : pType} {P : pFam A}
  {f g : pForall A P} (p : f = g)
  : phomotopy_path (p^) ==* (phomotopy_path p)^*.
Proof.
  induction p. simpl. symmetry. apply phomotopy_inverse_1.
Defined.

(* TODO: Remove [Funext] when whiskering is reproven without it. *)
Definition phomotopy_hcompose `{Funext} {A : pType} {P : pFam A} {f g h : pForall A P}
 {p p' : f ==* g} {q q' : g ==* h} (r : p ==* p') (s : q ==* q') :
  p @* q ==* p' @* q'.
Proof.
  exact ((s $@R p) $@ (q' $@L r)).
Defined.

Notation "p @@* q" := (phomotopy_hcompose p q).

(** Pointed homotopies in a set form an HProp. *)
Global Instance ishprop_phomotopy_hset `{Univalence} {X Y : pType} `{IsHSet Y} (f g : X ->* Y)
  : IsHProp (f ==* g).
Proof.
  rapply (transport IsHProp (x := {p : f == g & p (point X) = dpoint_eq f @ (dpoint_eq g)^})).
  apply path_universe_uncurried; issig.
Defined.


(* Andrew W. Appel and Stephen Yi-Hsien Lin,
    May 2013, October 2013, March 2014 *)

Require Recdef.
Require Import Integers.
Require Import Coqlib.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import List.

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

Transparent Int.repr.

Check skipn.
Print skipn.
Eval compute in skipn 2 [1, 2, 3, 4].

Lemma skipn_length:
  forall {A} n (al: list A),
    (length al >= n)%nat ->
    (length (skipn n al) = length al - n)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 apply IHn; omega.
Qed.

Lemma skipn_length_short:
  forall {A} n (al: list A),
    (length al < n)%nat ->
    (length (skipn n al) = 0)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 omega.
 apply IHn. omega.
Qed.

(* PREPROCESSING: CONVERTING STRINGS TO PADDED MESSAGE BLOCKS *)

Print string.
Print Z.of_N.

(*converting a string to a list of Z *)
Fixpoint str_to_Z (str : string) : list Z :=
  match str with
    |EmptyString => nil
    |String c s => Z.of_N (N_of_ascii c) :: str_to_Z s
    end.

Eval compute in str_to_Z "abc".

Print Int.repr.
Print Int.shl.

(*combining four Z into a Integer*)
(* list nl of byte values -- if length nl is a multiple of 4, easy to define corresponding list of bid-endian 32-bit integers *)

(* ?!?! TODO *)

Transparent Int.repr Int.or Int.shl.

(* is there a bitstring rep? that might make things clearer *)
Definition Z_to_Int (a b c d : Z) : Int.int :=
  Int.or
    (Int.or (Int.or
               (Int.shl (Int.repr a) (Int.repr 24))
               (Int.shl (Int.repr b) (Int.repr 16))
            )
               (Int.shl (Int.repr c) (Int.repr 8))
    )
    (Int.repr d).

(* TODO prove lemma about Z_to_int? *)
Transparent Z_to_Int.

Eval compute in Int.repr 24.
Eval compute in Int.or (Int.repr 24) (Int.repr 10).
Check Int.shl.
Eval compute in Int.shl (Int.repr 4) (Int.repr 1). (* 8 *)
Eval compute in Int.shl (Int.repr 4) (Int.repr 8). (* 8 *)
(* Eval compute in Z_to_Int 0. *)
Eval compute in
      Int.or (Int.or (Int.or (Int.shl (Int.repr 0) (Int.repr 24)) (Int.shl (Int.repr 0) (Int.repr 16)))
            (Int.shl (Int.repr 0) (Int.repr 8))) (Int.repr 900). (* ??? but generate_and_pad works fine *)

Print Int.repr.
Print Int.Z_mod_modulus.
Print Int.wordsize. Print Wordsize_32.wordsize. (* 32 *)
Print Int.P_mod_two_p.                          (* ??? *)
Print positive.

Goal Int.repr 5 = Z_to_Int 2 0 0 0.
  unfold Z_to_Int.
  unfold Int.repr.
  simpl.
  unfold Int.or.
  simpl.
  unfold Int.repr.
  unfold Int.shl.
  simpl.                        (* this can eval Z_to_Int just fine... *)

  (* is it actually an error for one of these to be > 8 bytes? (256 bits) *)
  (*
     1 0 0 0 = 16777216
     0 1 0 0 = 65526
     0 0 257 0 = 65792
     0 0 1 0 = 256
     0 0 0 257 = 257
     0 0 0 2 = 2
     0 0 0 1 = 1
*)

  (* TODO maybe better with coq bitstrings?? *)

  (* takes 4 big-endian bytes (each byte is 8 bits -> 32 bits -> 1 32-bit int, or 1 word)

so anyway, the result is (len nl) / 4 (int division)
  *)

  (* so is nl always a multiple of 4? yes, but ... you assumed that msg was a multiple of 4

TODO: prove
InWords (msg ++ [128%Z] (* 1 *) ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0)
(is multiple of 4)

 *)

Fixpoint Zlist_to_intlist (nl: list Z) : list int :=
  match nl with
  | h1::h2::h3::h4::t => Z_to_Int h1 h2 h3 h4 :: Zlist_to_intlist t
  | _ => nil
  end.

Eval compute in Int.repr (2^24).
Eval compute in Int.intval (Int.repr (2^24)).
Eval compute in Zlist_to_intlist [2, 0, 0, 0, 0, 0, 0, 1].

Print Z.to_nat.
Eval compute in (-5) mod 64.

(* TODO: figure out length of list_repeat *)
Definition generate_and_pad msg :=
  let n := Zlength msg in
   Zlist_to_intlist (msg ++ [128%Z] (* 1 *)
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0) (* 00...0 *)
           ++ [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]. (* length? in bytes *)

Eval compute in generate_and_pad [1].
Check generate_and_pad.

Definition lenint (n : Z) : list int :=
   [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]
.

Eval compute in lenint 4.
Eval compute in map Int.unsigned (lenint 4).

Print Int.unsigned.
Print Int.intval.

(* TODO is there an Int_to_Z... *)
Lemma length_pad_z_int :
  (* forall (n : Z), *)
   [Int.repr (5 * 8 / Int.modulus), Int.repr (5 * 8)]
   = Zlist_to_intlist [0, 0, 0, 0, 0, 0, 0, 0].
(* TODO figure out -- mult of 4? *)
Proof.
  simpl.
  unfold Z_to_Int.
  unfold Int.repr.
  simpl.
  unfold Int.or.
  simpl.
  unfold Int.repr.
  simpl.

Admitted.

Definition gap_nolen (msg : list Z) : list Z :=
  let n := Zlength msg in
    (msg ++ [128%Z] (* 1 *)
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0) (* 00...0 *)
.

Check gap_nolen.

Definition gap_len (msg : list Z) : list int :=
  let n := Zlength msg in
           [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]. (* length? in bytes *)

(* no length attached *)
Eval compute in gap_nolen [9, 9, 9].
(* 128%Z = ? *)

Fixpoint rep_helper {A : Type} (n : nat) (a : A) (l : list A) : list A :=
  match n with
    | 0%nat => l
    | S n' => rep_helper n' a (a :: l)
  end.

Definition rep {A : Type} (n : nat) (a : A) := rep_helper n a [].

Eval compute in rep_helper 10 5 [].

Eval compute in gap_len [1, 1, 1, 1].
(* if n * 8 > 2^32, then make it the first bit?? *)
Definition modl : nat := Z.to_nat Int.modulus.
Eval compute in gap_len (rep 200 2).
(* try doing rep modl 2, and Coq shuts down, even though rep_helper is tail-recursive *)

Print Zpos.
Check Zpos 5.
Print Z.
(* Inductive Z : Set :=  Z0 : Z | Zpos : positive -> Z | Zneg : positive -> Z *)
Print nat_iter.
Check (1%positive).
Print positive.                 (* ??? *)

Print Int.modulus.              (* 2^32 *)
Print Int.wordsize.
Goal 2^32 = Int.modulus.           (* neat! *)
  unfold Int.modulus.
  unfold Int.wordsize.
  unfold Wordsize_32.wordsize.
  (* stop here? *)
  unfold two_power_nat.
  unfold shift_nat.
  (* unfold Zpos. *)
  unfold nat_iter.              (* ?? *)
  reflexivity.
Qed.

Print Zlength_aux.

Transparent Int.repr.

Print Int.modulus.
Check Int.modulus.
Print Int.repr.
Check Int.repr.

(* block length? how to run? *)
(* can I change the spec? *)

Check generate_and_pad.
Eval compute in generate_and_pad nil.
Eval compute in map Int.unsigned (generate_and_pad nil).
Eval compute in length(map Int.unsigned (generate_and_pad [0])).
Eval compute in map Int.unsigned (generate_and_pad [1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 999999, 99999, 99999, 9999]).
(* how do I make the resulting length change?? *)
Eval compute in generate_and_pad [0].

(* list Z -> list int *)
(* Zlength? *)
Theorem equal_pad_length : forall (msg1 : list Z) (msg2 : list Z),
     msg1 = msg2 -> Zlength (generate_and_pad msg1) = Zlength (generate_and_pad msg2).
Proof.
  intros m1 m2 H.
  rewrite -> H.
  reflexivity.
Qed.

(* might need to rephrase this theorem,
e.g. len m1 = a -> len m2 = a -> len (gap m1) = b -> len (gap m2) = b... etc *)

(* What is the actual length of the padded message *)
(* Would be very if msg were inductively defined as a :: b :: c :: d :: list...
 nice induction on evidence (here we know msg % 4 = 0....)
*)
Theorem length_padded : forall (msg : list Z) (n : Z), (* or type nat? *)
                          Zlength msg = n -> Zlength (Zlist_to_intlist msg) = n / 4.
Proof.

Abort.

(* What is the actual length of the padded message *)
Theorem length_padded : forall (msg : list Z) (n : Z), (* or type nat? *)
                          Zlength msg = n -> Zlength (generate_and_pad msg) = n.
Proof.

Abort.

(* Theorem: length msg + 1 + length (repeat whatever -- TODO) + 2 *)
SearchAbout Zlength.

Lemma zlength_out : forall (l1 : list Z) (l2 : list Z),
                      Zlength (l1 ++ l2) = Zlength l1 + Zlength l2.
Proof.
  intros l1 l2.
  rewrite -> Zlength_correct.
  rewrite -> Zlength_correct.
  rewrite -> Zlength_correct.
  induction l1 as [ | x xs].
  (* l1 = nil *)
    simpl. reflexivity.
  (* l1 = x :: xs *)
    simpl.
    unfold Zlength.
    simpl.
    unfold Zlength in IHxs.
Admitted.                       (* ??? *)

(* i don't think InWords msg is actually a necessary implication
but it might make the proof a lot easier
 *)
Inductive InWords : list Z -> Prop :=
  | words_nil : InWords []
  | words_word : forall (a b c d : Z) (msg : list Z),
                   InWords msg -> InWords (a :: b :: c :: d :: msg).

Lemma pad_inwords :
  forall (msg : list Z),
    InWords (msg ++ [128]
                 ++ list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0).
Proof.
  intros msg.

Admitted.

Lemma zlength_intlist_zlist' :
  forall (msg1 : list Z) (msg2 : list Z) (pad : list Z),
    Zlength msg1 = Zlength msg2 ->
    Zlength (Zlist_to_intlist (msg1 ++ pad)) =
    Zlength (Zlist_to_intlist (msg2 ++ pad)).
Proof.
  intros msg1 msg2 pad Hlen.
  unfold Zlength.
  unfold Zlist_to_intlist.
  (* stuck *)

Admitted.

(* there are problems with Zlength too, especially the aux business *)

Lemma zlength_intlist_zlist :
  forall (msg1 : list Z) (msg2 : list Z) (pad : list Z),
    InWords (msg1 ++ pad) -> InWords (msg2 ++ pad) (* messy, fix *) ->
    Zlength msg1 = Zlength msg2 ->
    Zlength (Zlist_to_intlist (msg1 ++ pad)) =
    Zlength (Zlist_to_intlist (msg2 ++ pad)).
Proof.
  intros msg1 msg2 pad Hi1 Hi2 Hlen.
  generalize dependent msg2.
  induction Hi1.
    intros msg2 Hi2 Hlen. induction Hi2.              (* hmm, may have messed up double ind *)
      reflexivity.
      simpl. unfold Zlength. simpl. admit. (* contradiction *)
    intros msg2 Hi2 Hlen. induction Hi2.
      simpl. unfold Zlength. simpl. admit. (* contra *)
      simpl.
      unfold Zlength. simpl. unfold Zlength in IHHi2. simpl in IHHi2.

Admitted.

SearchAbout Zlength.
Print Zlength_aux.

(* TODO: would this lemma be easier if I rewrote generate and pad?
probably not

gap' =
  Zlist_to_intlist
  (msg ++ [128] ++ list_repeat (...) 0 ++ [lengthb1, lengthb2])

 *)
Theorem length_equal_pad_length : forall (msg1 : list Z) (msg2 : list Z),
     Zlength msg1  = Zlength msg2 ->
     Zlength (generate_and_pad msg1) = Zlength (generate_and_pad msg2).
Proof.
  intros m1 m2 H.
  unfold generate_and_pad.
  (* But Zlist_to_intlist is in the way :( *)
  rewrite -> H.

Abort.

(* ------ *)

(* Lemma 1 *)
(* maybe prefix is easier... *)
(* but message is *not* a prefix of the padded list, since it's Z list?
or, ok, intlist msg = Prefix (generate_and_pad msg)?
 *)

Inductive Prefix {X : Type} : list X -> list X -> Prop :=
  | p_nil : forall (l : list X), Prefix [] l
  | p_self : forall (l : list X), Prefix l l
  | p_cons : forall (l1 l2 : list X) (x : X), Prefix l1 l2 -> Prefix (x :: l1) (x :: l2)
  | p_append : forall (l1 l2 : list X) (l3 : list X), Prefix l1 l2 -> Prefix l1 (l2 ++ l3)
  | p_trans : forall (l1 l2 l3 : list X), Prefix l1 l2 -> Prefix l2 l3 -> Prefix l1 l2.
                               (* might want to prove some of these... too powerful *)
                     (* TODO *)

(* computational... (++) is not a constructor *)

Inductive Msg {X : Type} : Type :=
| Empty : Msg
| Word : X -> X -> X -> X -> Msg -> Msg.
(* not [Msg X -> Msg X]? *)

(* is this less efficient than list Z? nah *)

(* this is true for all msgs of type 4-block message, but not in general,
 since Zlist_to_intlist throws away trailing chunkc % 4 *)

(* TODO: define a 4-block message? *)
Theorem Zlist_to_intlist_dist : forall (l1 l2 : list Z),
     InWords l1
         -> Zlist_to_intlist (l1 ++ l2) = Zlist_to_intlist l1 ++ Zlist_to_intlist l2.
(* Prefix (Zlist_to_intlist l1) (Zlist_to_intlist l1 ++ l2) instead?? *)
Proof.
  intros l1 l2 Ewords.
  induction Ewords.
  (* words_nil *)
    reflexivity.
  (* words_word *)
    simpl.
    rewrite -> IHEwords.
    reflexivity.
Qed.

Lemma Zlist_to_intlist_prefix : forall (l1 l2 : list Z),
                                  InWords l1 ->
                                  Prefix (Zlist_to_intlist l1) (Zlist_to_intlist (l1 ++ l2)).
Proof.
  intros l1 l2 Ewords.
  induction Ewords.
  (* words_nil *)
    simpl. apply p_nil.
  (* words_word *)
    simpl. apply p_cons. apply IHEwords.
Qed.

(* TODO add case ltac *)
Theorem message_prefix_padded' : forall (msg : list Z),
              InWords msg -> Prefix (Zlist_to_intlist msg) (generate_and_pad msg).
Proof.
  intros msg Ewords.
  induction Ewords.             (* fix names *)
  (* words_nil *)
    simpl. apply p_nil.
  (* words_word *)
    unfold generate_and_pad.
    simpl.
    apply p_cons.
    apply p_append.
    apply Zlist_to_intlist_prefix.
    apply Ewords.
Qed.

(* TODO rewrite with implication? *)
(* OK, the premise is flawed, because we never do Zlist_to_intlist msg.
so we don't need InWords msg technically. But then how can we prove prefix?
is this good enough?
 *)
Theorem message_prefix_padded : forall (msg : list Z),
                                  Prefix (Zlist_to_intlist msg) (generate_and_pad msg).
Proof.
  intro msg.
  unfold generate_and_pad.
  apply p_append.
  induction msg as [ | x xs].
  (* msg = [] *)
    apply p_nil.
  (* msg = x :: xs *)
    simpl.

Admitted.

(* TODO: separate generate_and_pad function to generate . pad *)

(*ROUND FUNCTION*)

(*hardcoding the constants, first 32 bits of the fractional parts of the cube roots of the first 64 prime numbers*)
Print Int.repr.
Print Int.int.

Definition K256 := map Int.repr
  [1116352408 , 1899447441, 3049323471, 3921009573,
   961987163   , 1508970993, 2453635748, 2870763221,
   3624381080, 310598401  , 607225278  , 1426881987,
   1925078388, 2162078206, 2614888103, 3248222580,
   3835390401, 4022224774, 264347078  , 604807628,
   770255983  , 1249150122, 1555081692, 1996064986,
   2554220882, 2821834349, 2952996808, 3210313671,
   3336571891, 3584528711, 113926993  , 338241895,
   666307205  , 773529912  , 1294757372, 1396182291,
   1695183700, 1986661051, 2177026350, 2456956037,
   2730485921, 2820302411, 3259730800, 3345764771,
   3516065817, 3600352804, 4094571909, 275423344,
   430227734  , 506948616  , 659060556  , 883997877,
   958139571  , 1322822218, 1537002063, 1747873779,
   1955562222, 2024104815, 2227730452, 2361852424,
   2428436474, 2756734187, 3204031479, 3329325298].

Eval compute in Int.repr 1116352408.

(*functions used for round function*)
Definition Ch (x y z : int) : int :=
  Int.xor (Int.and x y) (Int.and (Int.not x) z).

Definition Maj (x y z : int) : int :=
  Int.xor (Int.xor (Int.and x z) (Int.and y z) ) (Int.and x y).

Definition Rotr b x := Int.ror x (Int.repr b).
Definition Shr b x := Int.shru x (Int.repr b).

Definition Sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 2 x) (Rotr 13 x)) (Rotr 22 x).
Definition Sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 6 x) (Rotr 11 x)) (Rotr 25 x).
Definition sigma_0 (x : int) : int :=
          Int.xor (Int.xor (Rotr 7 x) (Rotr 18 x)) (Shr 3 x).
Definition sigma_1 (x : int) : int :=
          Int.xor (Int.xor (Rotr 17 x) (Rotr 19 x)) (Shr 10 x).

(* word function *)
Function W (M: Z -> int) (t: Z) {measure Z.to_nat t} : int :=
  if zlt t 16
  then M t
  else  (Int.add (Int.add (sigma_1 (W M (t-2))) (W M (t-7)))
               (Int.add (sigma_0 (W M (t-15))) (W M (t-16)))).
Proof.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
intros; apply Z2Nat.inj_lt; omega.
Qed.

(*registers that represent intermediate and final hash values*)
Definition registers := list int.

Fixpoint map2 {A B C: Type} (f: A -> B -> C) (al: list A) (bl: list B) : list C :=
 match al, bl with
  | a::al', b::bl' => f a b :: map2 f al' bl'
  | _, _ => nil
  end.

(*initializing the values of registers, first thirty-two bits of the fractional
    parts of the square roots of the first eight prime numbers*)
Definition init_registers : registers :=
  map Int.repr  [1779033703, 3144134277, 1013904242, 2773480762,
                        1359893119, 2600822924, 528734635, 1541459225].

Definition nthi (il: list int) (t: Z) := nth (Z.to_nat t) il Int.zero.

Definition rnd_function (x : registers) (k : int) (w : int) : registers:=
  match x with
  |  [a, b, c, d, e, f, g, h] =>
     let T1 := Int.add (Int.add (Int.add (Int.add h (Sigma_1 e)) (Ch e f g)) k) w in
     let T2 := Int.add (Sigma_0 a) (Maj a b c) in
       [Int.add T1 T2, a, b, c, Int.add d T1, e, f, g]
  | _ => nil  (* impossible *)
  end.

Function Round  (regs: registers) (M: Z ->int) (t: Z)
        {measure (fun t => Z.to_nat(t+1)) t} : registers :=
 if zlt t 0 then regs
 else rnd_function (Round regs M (t-1)) (nthi K256 t) (W M t).
Proof. intros; apply Z2Nat.inj_lt; omega.
Qed.

Definition hash_block (r: registers) (block: list int) : registers :=
      map2 Int.add r (Round r (nthi block) 63).

Function hash_blocks (r: registers) (msg: list int) {measure length msg} : registers :=
  match msg with
  | nil => r
  | _ => hash_blocks (hash_block r (firstn 16 msg)) (skipn 16 msg)
  end.
Proof. intros.
 destruct (lt_dec (length msg) 16).
 rewrite skipn_length_short. simpl; omega. rewrite <- teq; auto.
 rewrite skipn_length. simpl; omega. rewrite <- teq; omega.
Qed.

Fixpoint intlist_to_Zlist (l: list int) : list Z :=
 match l with
 | nil => nil
 | i::r =>
     Int.unsigned (Shr 24 i) ::
     Int.unsigned (Int.and (Shr 16 i) (Int.repr 255)) ::
     Int.unsigned (Int.and (Shr 8 i) (Int.repr 255)) ::
     Int.unsigned (Int.and i (Int.repr 255)) ::
     intlist_to_Zlist r
 end.

(* ---------- Lemma 2 *)

Eval compute in intlist_to_Zlist [Int.repr 256].
Eval compute in intlist_to_Zlist [Int.repr 512].
Eval compute in intlist_to_Zlist [Int.repr 1024].
Eval compute in intlist_to_Zlist [Int.repr 2048].
Eval compute in intlist_to_Zlist [Int.repr 4096].

Definition g_a_p msg :=
  let n := Zlength msg in
   Zlist_to_intlist (msg ++ [128%Z] (* 1 *)
                ++ list_repeat (Z.to_nat (-(n + 9) mod 64)) 0) (* 00...0 *)
           ++ [Int.repr (n * 8 / Int.modulus), Int.repr (n * 8)]. (* length? in bytes *)

Eval compute in length (g_a_p [1]). (* 16 32 bit ints * 32 = 512 bits = 2 blocks *)
Eval compute in map Int.unsigned (g_a_p [1]). (* 16 32 bit ints * 32 = 512 bits = 2 blocks *)

(* TODO types *)

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

Definition g_a_p' (msg : list Z) : list int :=
  Zlist_to_intlist (pad msg).

Transparent Int.repr Int.or Int.shl Int.and.

SearchAbout app.                (* app_assoc, app_assoc_reverse *)

Lemma app_left : forall (a b c d : list Z),
   a ++ b ++ c ++ d = (a ++ b ++ c) ++ d.
Proof.
   intros a b c d.
   (* rewrite -> app_assoc.  do later*)
Admitted.

Definition fulllen (len : Z) :=
  len + 1%Z + (- (len + 9) mod 64). (* = -8 mod 64 = 56 mod 64??? not quite *)

Eval compute in fulllen 10.     (* + 8 = 64 *)
Eval compute in fulllen 1.
Eval compute in fulllen 0.
Eval compute in fulllen 100.    (* + 8 = 128 *)
Eval compute in fulllen 200.    (* + 8 = 256 *)
(* SHA-256 = block size 256 bits = 32 bit words (256 bits / (8 bits / byte) = 32 bytes?*)
(* Zlist to intlist: each Z is a byte; 4 bytes = 32 bit integer *)
Eval compute in

Theorem gap_compose_equal : forall (msg : list Z),
                              g_a_p' msg = generate_and_pad msg.
Proof.
  intros msg.
  unfold g_a_p'. unfold pad.
  unfold generate_and_pad.
  (* simpl. *) (* TODO doesn't work *)
  pose proof pad_inwords as pad_inwords.
  specialize (pad_inwords msg).
  remember (msg ++
                [128] ++
                list_repeat (Z.to_nat (- (Zlength msg + 9) mod 64)) 0) as pad_nolen.
  rewrite -> app_left.
  rewrite <- Heqpad_nolen.
  induction pad_inwords.
    (* case none *)
    (* simpl. *)                (* ? *)
    inversion Heqpad_nolen.     (* ? *)

(* x : list int

InWords (a ++ b ++ ... ++ c) ->

Zlist_to_intlist (a ++ b ++ ... ++ c ++ intlist_to_Zlist x)
= Zlist_to_intilst (a ++ b ++ ... ++ c) ++ x *)
(* see pad_inwords *)

Admitted.

Eval compute in g_a_p' [1].
Check g_a_p'.

Theorem prefix : forall (msg : list Z),
                   Prefix msg (pad msg).
Proof.
  intros msg.
  unfold pad.
  apply p_append.
  apply p_self.
Qed.

  (* --------- Lemma 2 ^ *)

Definition SHA_256 (str : list Z) : list Z :=
    intlist_to_Zlist (hash_blocks init_registers (generate_and_pad str)).