Require Import POCS.
Require Import OneDiskAPI.
Require Import BadBlockAPI.

Module RemappedDisk (bd : BadBlockAPI) <: OneDiskAPI.

  Import ListNotations.

  Definition read (a : addr) : proc block :=
    bs <- bd.getBadBlock;
    if a == bs then
      len <- bd.size;
      r <- bd.read (len-1);
      Ret r
    else
      r <- bd.read a;
      Ret r.

  Definition write (a : addr) (b : block) : proc unit :=
    bs <- bd.getBadBlock;
    len <- bd.size;
    if a == bs then
      _ <- bd.write (len-1) b;
      Ret tt
    else
      if a == (len-1) then
        Ret tt
      else
        _ <- bd.write a b;
        Ret tt.

  Definition size : proc nat :=
    len <- bd.size;
    Ret (len - 1).

  Definition init' : proc InitResult :=
    len <- bd.size;
    if len == 0 then
      Ret InitFailed
    else
      bs <- bd.getBadBlock;
      if (lt_dec bs len) then
        Ret Initialized
      else
        Ret InitFailed.

  Definition init := then_init bd.init init'.

  Definition recover: proc unit :=
    bd.recover.

  Inductive remapped_abstraction (bs_state : BadBlockAPI.State) (rd_disk : OneDiskAPI.State) : Prop :=
    | RemappedAbstraction :
      let bs_disk := stateDisk bs_state in
      let bs_addr := stateBadBlock bs_state in
      forall
        (* Fill in the rest of your abstraction here. *)
        (* To refer to the contents of disk [d] at address [a], you can write [diskGet d a] *) (* <-- TODO this was wrong*)
        (* To refer to the size of disk [d], you can write [diskSize d] *)
        (* You can try to prove [read_ok] to discover what you need from this abstraction *)

        (* Hint 1: What should be true about the non-bad blocks?   Replace [True] with what needs to be true *)
        (Hgoodblocks : forall a : nat, (a < diskSize rd_disk /\ not(a = bs_addr)) -> diskGet bs_disk a = diskGet rd_disk a)
        (* Hint 2: What should be true about the bad block? *)
        (Hbadblock : (bs_addr < diskSize rd_disk) -> diskGet rd_disk bs_addr = diskGet bs_disk (diskSize bs_disk - 1))

        (* when writing the above,  *)
        (* Hint 3: What if the bad block address is the last address? *)
        (Hsize : diskSize bs_disk = diskSize rd_disk + 1),
      remapped_abstraction bs_state rd_disk.

  Hint Constructors remapped_abstraction : core.

  Definition abstr : Abstraction OneDiskAPI.State :=
    abstraction_compose bd.abstr {| abstraction := remapped_abstraction |}.

  (* Note that these examples aren't trivial to prove, even if you have the
     right abstraction relation. They should help you think about whether your
     abstraction relation makes sense (although you may need to modify it to
     actually prove the implementation correct). *)

  Example abst_1_ok : forall Hinbounds,
    remapped_abstraction (BadBlockAPI.mkState [block1;block0;block0] 0 Hinbounds) [block0;block0].
  Proof.
    constructor; auto.
    simpl. intros.
    assert (a = 1).
    {
      lia.
    }
    intuition.
  Qed.

  Example abst_2_ok : forall Hinbounds,
    remapped_abstraction (BadBlockAPI.mkState [block1;block0] 0 Hinbounds) [block0].
  Proof.
    constructor; auto.
    simpl. intros.
    absurd (a < 1 /\ a <> 0).
    + lia.
    + apply H.
  Qed.

  Example abst_3_ok : forall Hinbounds,
    remapped_abstraction (BadBlockAPI.mkState [block0;block0] 1 Hinbounds) [block0].
  Proof.
    constructor; auto.
    - simpl. intuition.
      assert (a = 0).
      {
        lia.
      }
      intuition.
    - simpl. intuition. absurd (1 < 1).
      + lia.
      + apply H.
  Qed.

  (*Unset Printing Notations.*)

  Lemma some_eq : forall a b : block, Some a = Some b -> a = b.
  Proof.
    intros.
    injection H. trivial.
  Qed.

  Example abst_4_nok : forall Hinbounds,
    ~ remapped_abstraction (BadBlockAPI.mkState [block0;block0] 1 Hinbounds) [block1].
  Proof.
    intros.
    intro.
    inversion H. simpl in *.
    specialize (Hgoodblocks 0).
    unfold bs_addr in Hgoodblocks.
    simpl in Hgoodblocks. intuition.
    apply some_eq in Hgoodblocks.
    apply bytes_differ in Hgoodblocks.
    { contradiction. }
    unfold blockbytes. lia.
  Qed.

  Example abst_5_nok : forall Hinbounds,
    ~ remapped_abstraction (BadBlockAPI.mkState [block1;block1] 0 Hinbounds) [block0].
  Proof.
    intros.
    intro.
    inversion H; simpl in *.
    unfold bs_addr in Hbadblock.
    intuition.
    apply some_eq in Hbadblock.
    apply bytes_differ in Hbadblock.
    { contradiction. }
    unfold blockbytes.
    simpl. lia.
  Qed.

  (* Due to how remapped_abstraction is defined (as an inductive), it cannot be
  unfolded. This tactic identifies abstraction relations in the hypotheses and
  breaks them apart with [inversion], and also does some cleanup. *)
  Ltac invert_abstraction :=
    match goal with
    | H : remapped_abstraction _ _ |- _ => inversion H; clear H; subst; subst_var
    end.

  Theorem init_ok : init_abstraction init recover abstr inited_any.
  Proof.
    eapply then_init_compose; eauto.
    step_proc.
    destruct r as [| n].
    { simpl. step_proc. }
    simpl.
    step_proc.
    destruct (lt_dec r (S n)).
    {
      simpl. step_proc.
      exists (let bs_disk := stateDisk state in
         let bs_addr := stateBadBlock state in
         let shrunk := diskShrink bs_disk in
         let replaced := match diskGet bs_disk n with
                                               | None => block0
                                               | Some a => a
                                               end in
         diskUpd shrunk bs_addr replaced
        ).
      intuition.

      simpl.

      constructor.

      {
        intros.
        destruct H0.

        assert (a0 < diskSize (stateDisk state) - 1).
        {
          rewrite diskUpd_size in H0.
          rewrite diskShrink_size in H0.
          2: {
            rewrite <- H1. lia.
          }
          assumption.
        }

        rewrite <- diskShrink_preserves.
        2: {
          rewrite diskShrink_size.
          2: {
            rewrite <- H1. lia.
          }
          lia.
        }

        rewrite -> diskUpd_neq.
        2: {
          lia.
        }
        trivial.
      }
      {
        intros.
        rewrite diskUpd_size in H0.
        rewrite diskShrink_size in H0.
        2: {
          rewrite <- H1. lia.
        }

        rewrite -> diskUpd_eq.
        2: {
          rewrite diskShrink_size.
          2: {
            rewrite <- H1. lia.
          }
          lia.
        }
        assert (n = diskSize (stateDisk state) - 1).
        { lia. }

        assert (forall (z : nat) (r : block) (d : disk), z < diskSize d -> Some (match diskGet d z with
                                       | Some q => q
                                       | None => r
                                       end) = diskGet d z
               ).
        {
          intros.
          edestruct (diskGet d z) eqn:Heq.
          {
            trivial.
          }
          {
            apply disk_inbounds_not_none in Heq.
            2: { trivial. }
            contradiction.
          }
        }
        rewrite <- H2.
        apply H3.
        lia.
      }
      {
        rewrite diskUpd_size.
        rewrite diskShrink_size; lia.
      }
    }
    {
      step_proc.
    }
  Qed.

Theorem bad_block_inbounds :
    forall state,
      stateBadBlock state < diskSize (stateDisk state).
  Proof.
    intros.
    destruct state.
    simpl.
    exact stateBadBlockInBounds.
  Qed.

  Theorem read_ok : forall a, proc_spec (OneDiskAPI.read_spec a) (read a) recover abstr.
  Proof.
    unfold read.
    intros.

    apply spec_abstraction_compose; simpl.
    step_proc; eauto.

    destruct (a == r) eqn:Heq1.
    {

      step_proc.
      {
       exists state2. intuition.
      }
      step_proc.
      {
        exists state2. intuition.
      }
      step_proc; intuition.
      {
        exists state2. intuition.
        invert_abstraction.

        destruct (diskSize (stateDisk state) - 1 == stateBadBlock state).
        {
          (* bad block is out of bounds of spec; so diskGet spec bad_block is none.
           so any maybe_eq statement about it is true. *)
          assert (diskGet state2 (stateBadBlock state) = None).
          {
            rewrite <- e.
            rewrite -> Hsize.

            rewrite -> disk_oob_eq.
            2: {
              lia.
            }
            trivial.
          }
          unfold maybe_eq.
          apply holds_in_none_eq.
          assumption.
        }
        {
          (* bad block is not out of bounds. *)
          rewrite <- Hbadblock in H2.
          {
            apply H2 in n.
            assumption.
          }

          assert (stateBadBlock state < diskSize (stateDisk state)).
          {
            apply bad_block_inbounds.
          }
          lia.
        }
      }
      {
        exists state2. intuition.
      }
    }
    step_proc.
    {
      exists state2. intuition.
    }
    step_proc.
    {
      exists state2. intuition.
      invert_abstraction.
      case (lt_dec a (diskSize state2)); intros.
      {
        rewrite <- Hgoodblocks.
        2: {
          intuition.
        }
        assumption.
      }
      {
        assert (diskGet state2 a = None).
        {
          apply disk_oob_eq.
          assumption.
        }
        unfold maybe_eq.
        apply holds_in_none_eq.
        assumption.
      }
    }
    exists state2. intuition.
  Qed.

  (* Hint: you may find it useful to use the [pose proof (bad_block_inbounds state)]
     if you need [lia] to make use of the fact that the bad block is in-bounds. *)

  Theorem remapped_abstraction_diskUpd_remap : forall state state' s v_,
    remapped_abstraction state s ->
    stateBadBlock state' = stateBadBlock state ->
    stateDisk state' = diskUpd (stateDisk state) (diskSize (stateDisk state) - 1) v_ ->
    remapped_abstraction state' (diskUpd s (stateBadBlock state) v_).
  Proof.
    (*
      given a state,
      if we update the last slot,
      that maps to updating the bad block in the spec.
     *)
    intros.
    constructor.
    {
      (* proving Hgoodblocks. *)
      intros. intuition.
      invert_abstraction.
      rewrite -> H0 in H3.
      rewrite -> diskUpd_size in H2.
      rewrite -> H1.
      repeat rewrite -> diskUpd_neq by lia.
      apply Hgoodblocks.
      intuition.
    }
    {
      (* proving Hbadblock. *)
      intros.
      rewrite -> H0.
      rewrite -> H0 in H2.
      rewrite -> diskUpd_size in H2.
      rewrite -> H1.
      rewrite -> diskUpd_size.
      invert_abstraction.
      repeat rewrite -> diskUpd_eq by lia.
      trivial.
    }
    {
      (* proving Hsize. *)
      rewrite -> H1.
      rewrite diskUpd_size.
      rewrite diskUpd_size.
      invert_abstraction.
      assumption.
    }
  Qed.

  Theorem remapped_abstraction_diskUpd_noremap : forall state state' s a v_,
    remapped_abstraction state s ->
    a <> diskSize (stateDisk state) - 1 ->
    a <> stateBadBlock state ->
    stateBadBlock state' = stateBadBlock state ->
    stateDisk state' = diskUpd (stateDisk state) a v_ ->
    remapped_abstraction state' (diskUpd s a v_).
  Proof.
    (*
      given a state, and an address that is neither the bad block
      nor the final block, updating the address is equivalent to updating
      the spec.
     *)
    intros. constructor.
    {
      (* Proving Hgoodblocks. *)
      intros. intuition.
      rewrite -> H2 in H5.
      rewrite -> diskUpd_size in H4.
      rewrite -> H3.
      invert_abstraction.
      case (equal_dec a a0).
      {
        intros.
        rewrite <- e.
        repeat rewrite diskUpd_eq by lia.
        trivial.
      }
      {
        intros.
        repeat rewrite diskUpd_neq by lia.
        apply Hgoodblocks.
        lia.
      }
    }
    {
      (* Proving Hbadblock. *)
      intros.
      rewrite -> H2 in H4.
      rewrite -> H2.
      rewrite -> H3.
      invert_abstraction.
      rewrite -> diskUpd_size.
      repeat rewrite diskUpd_neq by lia.
      apply Hbadblock.
      rewrite diskUpd_size in H4.
      assumption.
    }
    {
      (* Hsize. *)
      rewrite -> H3.
      rewrite diskUpd_size.
      rewrite diskUpd_size.
      invert_abstraction.
      assumption.
    }

  Qed.

  Hint Resolve remapped_abstraction_diskUpd_remap : core.
  Hint Resolve remapped_abstraction_diskUpd_noremap : core.

  Theorem write_ok : forall a v_, proc_spec (OneDiskAPI.write_spec a v_) (write a v_) recover abstr.
  Proof.
    unfold write.
    intros.

    apply spec_abstraction_compose; simpl.
    step_proc.
    {
      exists state2. intuition.
    }
    case (equal_dec a r) as [Hwrite_bad | Hwrite_other].
    {
      step_proc.
      {
        exists state2. intuition.
      }
      step_proc.
      {
        destruct H1 as [Hcrash_before | Hcrash_after].
        {
          exists state2. intuition.
        }
        {
          exists (diskUpd state2 (stateBadBlock state) v_). intuition.
        }
      }
      step_proc.
      {
        exists (diskUpd state2 (stateBadBlock state) v_). intuition.
      }
      exists (diskUpd state2 (stateBadBlock state) v_). intuition.
    }
    {
      step_proc.
      {
        exists state2. intuition.
      }
      case (equal_dec a (r - 1)) as [Hwrite_silly | Hwrite_nonsilly].
      {
        step_proc.
        {
          exists state2. intuition.
          invert_abstraction.
          rewrite Hsize.
          rewrite diskUpd_none.
          2: {
            rewrite -> disk_oob_eq by lia.
            trivial.
          }
          trivial.
        }
        {
          exists state2. intuition.
        }
      }
      {
        step_proc.
        {
          destruct H1 as [Hcrash_before | Hcrash_after].
          {
           exists state2. intuition.
          }
          {
            exists (diskUpd state2 a v_).
            intuition.
            eauto.
          }
        }
        step_proc.
        {
          exists (diskUpd state2 a v_). intuition. eauto.
        }
        {
          exists (diskUpd state2 a v_). intuition. eauto.
        }
      }
    }
  Qed.

  Theorem size_ok : proc_spec OneDiskAPI.size_spec size recover abstr.
  Proof.
    unfold diskSize.
    intros.

    apply spec_abstraction_compose; simpl.

    step_proc; eauto.
    step_proc.
    {
      exists state2. intuition.
      invert_abstraction.
      rewrite -> Hsize. lia.
    }
    {
      exists state2. intuition.
    }
  Qed.

  (* This proof proves that recovery corresponds to no_wipe. *)
  Theorem recover_wipe : rec_wipe recover abstr no_wipe.
  Proof.
    unfold rec_wipe.
    intros.

    apply spec_abstraction_compose; simpl.
    step_proc; eauto.
  Qed.

End RemappedDisk.

Require Import BadBlockImpl.
Module x := RemappedDisk BadBlockDisk.
Print Assumptions x.write_ok.


(* -*- coq-prog-args: ("-emacs" "-indices-matter" "-type-in-type") -*- *)

Require Export Utf8_core.
Require Import HoTT HoTT.hit.Truncations Connectedness.
Require Import PathGroupoid_.

Set Universe Polymorphism.
Global Set Primitive Projections.

Local Open Scope path_scope.
Local Open Scope type_scope.

Module Export T.

  Private Inductive T {A B:Type} (f: A -> B) : Type :=
    | t : A -> (T f).

  Arguments t {A B f} a.

  Axiom tp : forall {A B f} (a b:A), f a = f b -> @t A B f a = @t A B f b.

  Axiom tp_1 : forall {A B f} (a:A), @tp A B f a a 1 = 1.

  Definition T_ind {A B:Type} {f:A -> B} (P : T f -> Type)
             (t' : forall a, P (t a))
             (tp' : forall a b p, transport P (tp a b p) (t' a) = t' b)
             (tp_1' : forall a, transport2 P (tp_1 a) (t' a) = tp' a a 1)
    : forall w, P w
    := fun w => match w with
                |t a => fun _ => t' a
                end tp_1'.

  Axiom T_ind_beta_tp : forall {A B:Type} {f:A -> B} (P : T f -> Type)
             (t' : forall a, P (t a))
             (tp' : forall a b p, transport P (tp a b p) (t' a) = t' b)
             (tp_1' : forall a, transport2 P (tp_1 a) (t' a) = tp' a a 1)
             a b p,
      apD (T_ind P t' tp' tp_1') (tp a b p) = tp' a b p.

  Axiom T_ind_beta_tp_1 : forall {A B:Type} {f:A -> B} (P : T f -> Type)
             (t' : forall a, P (t a))
             (tp' : forall a b p, transport P (tp a b p) (t' a) = t' b)
             (tp_1' : forall a, transport2 P (tp_1 a) (t' a) = tp' a a 1)
             a,
      apD02 (T_ind P t' tp' tp_1') (tp_1 a) @ (concat_p1 _) @ (tp_1' a) = T_ind_beta_tp P t' tp' tp_1' a a 1.

End T.

Definition T_rec {A B:Type} {f:A -> B} (P:Type)
           (t': A -> P)
           (tp' : forall (a b:A) (p:f a = f b), t' a = t' b)
           (tp_1' : forall a, tp' a a 1 = 1)
  : T f -> P.
Proof.
  simple refine (T_ind _ t' (fun a b p => transport_const _ _ @ tp' a b p)  _).
  intro a.
  pose (p:=whiskerR (transport2_const (A:=T f) (B:= P) (tp_1 a) (t' a) @ concat_p1 _)^ (tp' a a 1)). cbn in p.
  pose (p1:=(whiskerL (transport2 (λ _ : T f, P) (tp_1 a) (t' a)) (tp_1' a) @ concat_p1 _)^).
  exact (p1 @ p).
Defined.

Definition T_rec_beta_tp {A B:Type} {f:A -> B} (P:Type)
           (t': A -> P)
           (tp' : forall (a b:A) (p:f a = f b), t' a = t' b)
           (tp_1' : forall a, tp' a a 1 = 1)
           a b p
  : ap (T_rec P t' tp' tp_1') (tp a b p) = tp' a b p.
Proof.
  simple refine (cancelL (transport_const (tp a b p) (t' a)) _ _ _).
  pose (e1:= T_ind_beta_tp (λ _ : T f, P) t'
        (λ (a0 b0 : A) (p1 : f a0 = f b0),
         transport_const (tp a0 b0 p1) (t' a0) @ tp' a0 b0 p1)
        (λ a0 : A,
         (whiskerL (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0))
            (tp_1' a0) @
          concat_p1 (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0)))^ @
         whiskerR
           (transport2_const (tp_1 a0) (t' a0) @
            concat_p1 (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0)))^
         (tp' a0 a0 1)) a b p).

  pose (e2:= apD_const (T_ind (λ _ : T f, P) t'
        (λ (a0 b0 : A) (p2 : f a0 = f b0),
         transport_const (tp a0 b0 p2) (t' a0) @ tp' a0 b0 p2)
        (λ a0 : A,
         (whiskerL (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0))
            (tp_1' a0) @
          concat_p1 (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0)))^ @
         whiskerR
           (transport2_const (tp_1 a0) (t' a0) @
            concat_p1 (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0)))^
         (tp' a0 a0 1))) (tp a b p)).
  exact (e2^@ e1).
Defined.

Definition T_rec_beta_tp_1 {A B:Type} {f:A -> B} (P:Type)
           (t': A -> P)
           (tp' : forall (a b:A) (p:f a = f b), t' a = t' b)
           (tp_1' : forall a, tp' a a 1 = 1)
           a
  : ap02 (T_rec P t' tp' tp_1') (tp_1 a) = T_rec_beta_tp P t' tp' tp_1' a a 1 @ (tp_1' a).
Proof.
  apply (cancel2L (transport2_const (tp_1 (f:=f) a) (t' a))).
  apply (cancelL (apD_const (T_rec P t' tp' tp_1') (tp a a 1))).
  apply (cancelR _ _ (concat_p_pp _ (transport_const _ _) _)^).
  apply (cancelR _ _ (whiskerL (transport2 _ (tp_1 a) (t' a)) (apD_const (T_rec P t' tp' tp_1') 1)^)).
  simple refine ((apD02_const (T_rec P t' tp' tp_1') (tp_1 a) )^ @ _).
  apply (cancelR _ _ (concat_p1 (transport2 (λ _ : T f, P) (tp_1 a) (t' a)))).
  apply (cancelR _ _ ((whiskerL (transport2 (λ _ : T f, P) (tp_1 a) (t' a)) (tp_1' a) @
                                concat_p1 (transport2 (λ _ : T f, P) (tp_1 a) (t' a)))^ @
                                                                                whiskerR
                                                                                (transport2_const (tp_1 a) (t' a) @
                                                                                concat_p1 (transport2 (λ _ : T f, P) (tp_1 a) (t' a)))^
                      (tp' a a 1))).
  Opaque concat_p_pp.
  simple refine (T_ind_beta_tp_1 _ _ _ _ _ @ _); cbn.
  apply (cancelL (apD_const
                    (T_ind (λ _ : T f, P) t'
                           (λ (a0 b0 : A) (p2 : f a0 = f b0),
                            transport_const (tp a0 b0 p2) (t' a0) @ tp' a0 b0 p2)
                           (λ a0 : A,
                                   (whiskerL (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0))
                                             (tp_1' a0) @
                                             concat_p1
                                             (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0)))^ @
                                                                                whiskerR
                                                                                (transport2_const (tp_1 a0) (t' a0) @
                                                                                concat_p1
                                                                                (transport2 (λ _ : T f, P) (tp_1 a0) (t' a0)))^
                                   (tp' a0 a0 1))) (tp a a 1))^).

  apply (@equiv_inj _ _ _ (isequiv_cancelL (transport_const (tp a a 1) (t' a))
                                           (ap (T_rec P t' tp' tp_1') (tp a a 1))
                                           (tp' a a 1))).

  path_via (T_rec_beta_tp P t' tp' tp_1' a a 1).
  apply (@equiv_inj _ _ _ (isequiv_inverse _ (feq:= isequiv_cancelL (transport_const (tp (f:=f) a a 1) (t' a))
                                                                    (ap (T_rec P t' tp' tp_1') (tp a a 1))
                                                                    (tp' a a 1)))).
  rewrite eissect. cbn. repeat rewrite concat_pp_p.
  rewrite concat_V_pp.
  rewrite !inv_pp. repeat rewrite concat_p_pp. rewrite concat_pp_V.

  rewrite whiskerR_pp.
  rewrite whiskerR_RV.
  rewrite <- (apD (λ u, (whiskerR (concat_p1 (transport2 (λ _ : T f, P) (tp_1 a) (t' a)))
                                  u)) (tp_1' a)^).
  cbn. rewrite transport_paths_FlFr. cbn. rewrite !ap_V; rewrite !inv_V.
  rewrite !concat_ap_pFq. rewrite ap_idmap. rewrite !inv_pp; rewrite !inv_V.
  rewrite !concat_p_pp. rewrite concat_pV_p. rewrite (concat_p1 ((transport2_const (tp_1 a) (t' a) @@
                                                                                (T_rec_beta_tp P t' tp' tp_1' a a 1 @ tp_1' a)) @
                                                                                (concat_p_pp (transport2 (λ _ : T f, P) (tp_1 a) (t' a)) 1 1)^)).
  rewrite whiskerR_RV.
  apply moveL_pV.
  unfold whiskerR at 1, whiskerL at 1.
  rewrite concat_concat2. cbn.
  rewrite (concat_1p (transport2_const (tp_1 a) (t' a))).
  rewrite (concat_p1 (T_rec_beta_tp P t' tp' tp_1' a a 1)).
  simple refine ((concat_p1 _)^ @ _). rewrite !concat_pp_p.
  match goal with
  |[|- _ = (?P @@ ?Q) @ ?R] => path_via (((P @ 1) @@ Q) @ R)
  end.
  2: rewrite (concat_p1 (transport2_const (tp_1 a) (t' a))); reflexivity.
  rewrite <- concat_concat2.
  rewrite !concat_pp_p. apply whiskerL.
  rewrite !concat_p_pp. apply moveL_pV. rewrite concat_1p.
  rewrite !concat_pp_p. simple refine ((concat_p1 _)^@ _).
  apply whiskerL. cbn.
  pose (rew:= @triangulator _ _ _ _ (transport2 (λ _ : T f, P) (tp_1 a) (t' a)) 1).
  apply moveL_Vp in rew. rewrite rew; clear rew. cbn.
  rewrite inv_pp. cbn. rewrite concat_1p. symmetry; apply concat_pV.
Qed.

Lemma path_T_lemma {A A' B:Type} (f: A -> A')
      (α β : T f -> B)
      (eq1: α o t == β o t)
      (eq2: forall a b p, eq1 a @ ap β (tp a b p) = ap α (tp a b p) @ eq1 b)
      (eq3: forall a,  (eq2 a a 1)
                       = transport (λ U, eq1 a @ ap β U = ap α U @ eq1 a) (tp_1 a)^ (concat_p1 (eq1 a) @ (concat_1p (eq1 a))^))
  : ∀ a : A,
    transport2 (λ w : T f, α w = β w) (tp_1 a) (eq1 a) =
    transport_paths_FlFr (tp a a 1) (eq1 a) @
                         (concat_pp_p (ap α (tp a a 1))^
                          (eq1 a)
                            (ap β (tp a a 1))
                            @ cancelL (ap α (tp a a 1))
                            ((ap α (tp a a 1))^ @ (eq1 a @ ap β (tp a a 1)))
                            (eq1 a)
                            (concat_p_Vp (ap α (tp a a 1)) (eq1 a @ ap β (tp a a 1)) @ eq2 a a 1)).
Proof.
  intro a; cbn.
  rewrite eq3; clear eq3. clear eq2. generalize (eq1 a). intro p. clear eq1.
  unfold cancelL.
  pose (rew :=@transport_paths_FlFr _ _ (λ U:t a = t a, p @ ap β U) (λ U:t a = t a, ap α U @ p)).
  rewrite rew; clear rew.
  cbn.
  repeat rewrite concat_pp_p.
  rewrite ap_V. rewrite inv_V.
  repeat rewrite whiskerL_pp.
  symmetry.

  match goal with
  |[|- ?PP1 @ (?PP2 @ ((?PP3 @ (?PP4 @ ((?PP5 @ (?PP6 @ ?PP7)) @ ?PP8)) @ ?PP9))) = ?PP10] =>
   set (P1 := PP1);
     set (P2 := PP2);
     set (P3 := PP3);
     set (P4 := PP4);
     set (P5 := PP5);
     set (P6 := PP6);
     set (P7 := PP7);
     set (P8 := PP8);
     set (P9 := PP9);
     set (P10 := PP10)
  end.
  rewrite (@concat_pp_p _ _ _ _ _ P3 (P4 @ ((P5 @ (P6 @ P7)) @ P8)) P9).
  rewrite (@concat_pp_p _ _ _ _ _ P4 ((P5 @ (P6 @ P7)) @ P8) P9).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P5 _ _).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P6 _ _).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P7 _ _).

  unfold P1; clear P1.
  match goal with
  |[|- ?ff _ p @ _ = _]
   => rewrite <- (apD (λ U, ff U p) (tp_1 a)^)
  end.
  cbn.
  rewrite (transport_paths_FlFr (f:= λ U, transport (λ x : T f, α x = β x) U p)
                                (g:= λ U, ((ap α U)^ @ p) @ ap β U)).
  rewrite ap_V. rewrite inv_V.

  unfold P10. rewrite transport2_is_ap.
  repeat rewrite concat_pp_p.
  match goal with
  |[|- _ = ?XX] => path_via (XX @ 1)
  end.
  apply whiskerL.
  rewrite ap_V.
  do 3 apply moveR_Vp.
  match goal with
  |[|- _ = ?PP11 @ (?PP12 @ ?PP13)]
   => set (P11 := PP11); set (P12 := PP12); set (P13 := PP13); cbn in *
  end.

  unfold P3; clear P3.

  rewrite <- (apD (λ U, (concat_V_pp (ap α U)
                                     ((ap α U)^ @ (p @ ap β U)))^) (tp_1 a)^).
  cbn.
  rewrite (transport_paths_FlFr (f:=(λ U : t a = t a, (ap α U)^ @ (p @ ap β U)))
                                (g:=λ U : t a = t a, (ap α U)^ @ (ap α U @ ((ap α U)^ @ (p @ ap β U))))).
  rewrite ap_V. rewrite inv_V.
  match goal with
  |[|- _ @ (((?PP31 @ ?PP32) @ ?PP33) @ _) = _] =>
   set (P31 := PP31); set (P32 := PP32); set (P33 := PP33); cbn in *
  end.
  repeat rewrite (@concat_pp_p _ _ _ _ _ P31).
  repeat rewrite (@concat_pp_p _ _ _ _ _ P32).
  rewrite (@concat_p_pp _ _ _ _ _ P2 P31 _).

  assert (rr: P11 @ (concat_pp_p _ _ _) = (P2 @ P31)).
  { unfold P2, P31, P11.
    rewrite concat_ap_FpFq_pp_p. rewrite concat_ap_FpFq_p_pp.
    unfold whiskerR, whiskerL.
    repeat rewrite concat_p_pp. apply whiskerR.
    reflexivity. }
  destruct rr.
  rewrite (@concat_pp_p _ _ _ _ _ P11).
  apply whiskerL.
  match goal with |[|- ?PP1 @ _ = _] => set (P1 := PP1) end.
  clear P10; clear P11.

  do 2 apply moveR_Mp.
  repeat rewrite (concat_p_pp _ _ P9). apply moveR_pM.
  unfold P9.
  rewrite <- (apD (λ U, (concat_V_pp (ap α U) p)^) (tp_1 a)^). simpl.
  rewrite (transport_paths_Fr (g:= λ U, (ap α U)^ @ (ap α U @ p))).
  clear P2.
  repeat rewrite (concat_p_pp _ _ P8).
  apply moveR_pM.
  set (P2 := ap (λ U : t a = t a, (ap α U)^ @ (ap α U @ p)) (tp_1 a)^).

  unfold P8.
  rewrite <- (apD (λ U, whiskerL (z:=β (t a)) (q:= 1 @ p) (r := ap α (tp a a 1) @ p) (ap α U)^) (tp_1 a)^).
  rewrite transport_arrow.
  simpl.
  rewrite transport_const.
  rewrite transport_paths_FlFr.
  do 2 rewrite inv_pp.
  repeat rewrite ap_V. rewrite whiskerL_LV. repeat rewrite inv_V.
  match goal with
  |[|- _ = _ @ (?PP16 @ (?PP15 @ ?PP14)) ] =>
   set (P14 := PP14); set (P15 := PP15); set (P16 := PP16); simpl in P14, P15, P16
  end.
  unfold P4.
  rewrite <- (apD (λ U, (whiskerL (ap α U)^
                         (concat_p_Vp (ap α U) (p @ ap β U)))) (tp_1 a)^).
  simpl.
  rewrite transport_paths_FlFr. simpl.
  rewrite ap_V. rewrite inv_V.
  match goal with
  |[|- _ @ (((?PP17 @ ?PP18) @ ?PP19) @ _) = _]
   => set (P17:=PP17); set (P18 := PP18); set (P19 := PP19)
  end.
  clear P4. clear P8. clear P9. clear P31.
  unfold P6, P7; clear P6; clear P7.
  rewrite <- (apD (λ U, (whiskerL (ap α U)^ (concat_p1 p) @
                                                          whiskerL (ap α U)^ (concat_1p p)^)) (tp_1 a)^).
  simpl.
  rewrite transport_paths_FlFr.
  rewrite ap_V. rewrite inv_V.
  match goal with
  |[|- _ @ (_ @ (_ @ ((?PP6 @ ?PP7) @ ?PP8))) = _]
   => set (P6:=PP6); set (P7:=PP7); set (P8:=PP8)
  end.

  unfold P5; clear P5.
  rewrite <- (apD (λ U, whiskerL (q:=p @ ap β (tp a a 1)) (r:=p@1) (ap α U)^) (tp_1 a)^).
  rewrite transport_arrow.
  rewrite transport_const. rewrite transport_paths_FlFr.
  simpl.
  rewrite ap_V. rewrite inv_V.
  repeat rewrite (concat_p_pp _ _ P8).
  repeat rewrite (concat_p_pp _ _ P14).

  unfold P8, P14. repeat rewrite ap_V. apply whiskerR. clear P8; clear P14.
  repeat rewrite (concat_pp_p P17 _ _).
  rewrite <- (concat_pp_p P33 P17 _).
  unfold P33, P17; clear P33; clear P17.
  rewrite ap_V. rewrite concat_Vp.
  match goal with |[|- 1 @ ?XX = _] => rewrite (concat_1p XX) end.
  pose (p1 := whiskerL_1p (concat_p_Vp 1 (p @ 1))). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  unfold P18; clear P18; rewrite p1; clear p1.
  unfold P15; clear P15.
  pose (p1 := whiskerL_1p (ap (λ U : t a = t a, ap α U @ p) (tp_1 a))). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  unfold P7; clear P7.
  pose (p1 := whiskerL_1p (concat_p1 p)). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  pose (p1 := whiskerL_1p (concat_1p p)^). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  pose (p1 := whiskerL_1p (ap (λ U : t a = t a, p @ ap β U) (tp_1 a))). simpl in p1.
  apply moveL_pV in p1.
  apply moveL_Mp in p1.
  rewrite p1; clear p1.
  repeat rewrite concat_pp_p.
  unfold  P19, P6, P32, P1, P12, P13, P2, P16.
  clear P19; clear P6; clear P32; clear P1; clear P12; clear P13; clear P2; clear P16.
  (* rewrite inv_V. *)
  rewrite (concat_p1 (concat_1p p)).
  match goal with
  |[|- ?PP1 @ (?PP2 @ (?PP3 @ (?PP4 @ (?PP5 @ (?PP6 @ (?PP7 @ (?PP8 @ (?PP9 @ (?PP10 @ (?PP11 @ (?PP12 @ (?PP13 @ (?PP14 @ (?PP15 @ (?PP16)))))))))))))))
       =
       ?PP17 @ (?PP18 @ ((?PP19 @ ?PP20) @ ((?PP21 @ ?PP22) @ (?PP23 @ (?PP24 @ (?PP25 @ ?PP26))))))] =>
   set (P1 := PP1);
     set (P2 := PP2);
     set (P3 := PP3);
     set (P4 := PP4);
     set (P5 := PP5);
     set (P6 := PP6);
     set (P7 := PP7);
     set (P8 := PP8);
     set (P9 := PP9);
     set (P10 := PP10);
     set (P11 := PP11);
     set (P12 := PP12);
     set (P13 := PP13);
     set (P14 := PP14);
     set (P15 := PP15);
     set (P16 := PP16);
     set (P17 := PP17);
     set (P18 := PP18);
     set (P19 := PP19);
     set (P20 := PP20);
     set (P21 := PP21);
     set (P22 := PP22);
     set (P23 := PP23);
     set (P24 := PP24);
     set (P25 := PP25);
     set (P26 := PP26)
  end.
  repeat rewrite (concat_p_pp _ _ P16).
  apply whiskerR. clear P16.
  assert (rr : 1 = P14 @ P13).
  symmetry. unfold P13, P14. apply concat_pV.
  destruct rr. rewrite (concat_p1 P13).
  clear P15. clear P20. simpl in *.
  assert (rr: P1 @ (P2 @ P3) = P17).
  { unfold P1, P2, P3, P17.
    clear P1; clear P2; clear P17;
    clear P3; clear P4; clear P5; clear P6; clear P7; clear P8; clear P9
    ; clear P10; clear P11; clear P12; clear P13; clear P14; clear P18; clear P19
    ; clear P21; clear P22; clear P23; clear P24; clear P25; clear P26.
    destruct p. reflexivity. }
  destruct rr.
  repeat rewrite concat_pp_p.
  do 3 apply whiskerL.
  clear P1; clear P2; clear P26.

  assert (rr: P18 @ (P19 @ P14) = P11 @ P12).
  { unfold P18, P19, P14, P11, P12. cbn.
    clear P3; clear P4; clear P5; clear P6; clear P7; clear P8; clear P9
    ; clear P10; clear P11; clear P12; clear P13; clear P14; clear P18; clear P19
    ; clear P21; clear P22; clear P23; clear P24; clear P25.
    destruct p; reflexivity. }
  rewrite (concat_p_pp _ (P19 @ P14)).
  rewrite rr; clear rr.
  rewrite (concat_p_pp P9).
  unfold P9, P10. rewrite concat_Vp. rewrite (concat_1p (P11 @ (P12 @ P13))).
  clear P9; clear P10.
  rewrite (concat_p_pp P3).
  unfold P3 at 1, P11 at 1. rewrite concat_Vp.
  rewrite (concat_1p (P12 @ P13)).
  clear P3.
  assert (rr: P4 @ (P5 @ (P6 @ P7)) = P11).
  { repeat rewrite (concat_p_pp _ _ P7).
    apply moveR_pM.

    unfold P4, P5, P6, P7, P11.
    clear P4; clear P5; clear P6; clear P7; clear P8
    ; clear P11; clear P12; clear P13; clear P14; clear P18; clear P19
    ; clear P21; clear P22; clear P23; clear P24; clear P25.
    rewrite <- (ap_V (λ U : t a = t a, p @ ap β U) (tp_1 a)).
    rewrite ap_V. apply moveR_Vp.

    rewrite <- (apD (λ U, concat_1p (p @ ap β U)) (tp_1 a)^).
    simpl.
    rewrite transport_paths_FlFr. simpl.
    rewrite ap_V. rewrite inv_V.
    repeat rewrite concat_p_pp.
    match goal with
    |[|- ?P1 @ (?P2 @ ?P3) = _]
     => rewrite (concat_p_pp P1)
    end. apply whiskerR.
    match goal with
    |[|- ?P1 @ (?P2 @ ?P3) = _]
     => rewrite (concat_p_pp P1)
    end. apply whiskerR.
    rewrite concat_ap_Fpq.
    unfold whiskerR.
    rewrite concat_ap_pFq. unfold whiskerL.
    rewrite concat_concat2. rewrite (concat_p1 (ap (λ u : t a = t a, (ap α u)^) (tp_1 a))).
    rewrite (concat_1p (ap (λ u : t a = t a, p @ ap β u) (tp_1 a))).
    rewrite concat_ap_FpFq_p_pp.
    unfold whiskerR, whiskerL.
    rewrite concat_pp_p. apply moveL_Mp.
    rewrite concat2_inv.
    rewrite concat_concat2.
    rewrite concat_Vp.
    rewrite (concat_1p (ap (λ u : t a = t a, p @ ap β u) (tp_1 a))).
    rewrite concat_ap_pFq. unfold whiskerL.
    rewrite (concat2_p_pp). reflexivity. }
  rewrite (concat_pp_p P11).
  destruct rr.
  rewrite (concat_pp_p P4); apply whiskerL.
  rewrite (concat_pp_p P5); apply whiskerL.
  rewrite (concat_pp_p P6); apply whiskerL.
  do 2 apply whiskerL.
  clear P4; clear P5; clear P6; clear P7; clear P8; clear P12.
  clear P14; clear P18; clear P19.
  unfold P13, P21, P22, P23, P24, P25.
  clear P13; clear P21; clear P22; clear P23; clear P24; clear P25.
  rewrite <- (apD (λ U, concat_1p (ap α U @ p)) (tp_1 a)^).
  rewrite transport_paths_FlFr. simpl.
  repeat rewrite ap_V. rewrite inv_V.
  repeat rewrite concat_pp_p. rewrite concat_Vp.
  rewrite (concat_p1).
  apply moveL_Vp.
  repeat rewrite (concat_p_pp _ _ (concat_1p (1 @ p))). apply moveL_pM.
  match goal with
  |[|- ?XX = _] => assert (rr: 1 = XX)
  end.
  { destruct p. reflexivity. }
  destruct rr.
  apply moveL_Vp. rewrite concat_p1.
  rewrite concat_ap_Fpq.
  rewrite concat_ap_pFq. unfold whiskerR, whiskerL.
  rewrite concat_concat2.
  rewrite concat_p1, (concat_1p (ap (λ u : t a = t a, ap α u @ p) (tp_1 a))).
  rewrite concat_ap_FFpq_p_pp. rewrite concat_ap_Fpq.
  unfold whiskerR. simpl.
  rewrite <- concat2_p_pp. reflexivity.
Qed.

Lemma path_T {A A' B:Type} (f: A -> A')
      (α β : T f -> B)
      (eq1: α o t == β o t)
      (eq2: forall a b p, eq1 a @ ap β (tp a b p) = ap α (tp a b p) @ eq1 b)
      (eq3: forall a,  (eq2 a a 1)
                      = transport (λ U, eq1 a @ ap β U = ap α U @ eq1 a) (tp_1 a)^ (concat_p1 (eq1 a) @ (concat_1p (eq1 a))^))
  : α == β.
Proof.
  simple refine (T_ind _ _ _ _).
  - exact eq1.
  - intros a b p.
    simple refine (transport_paths_FlFr _ _ @ _).
    etransitivity; try apply concat_pp_p.
    apply (cancelL (ap α (tp a b p))).
    etransitivity; try apply eq2.
    apply concat_p_Vp.
  - simple refine (path_T_lemma _ _ _ _ _ _). exact eq3.
Defined.

Lemma T_trunc_fun `{fs: Funext} (m:trunc_index) (A:Type) (B:TruncType m) (f:A -> B)
  : Trunc m (T f) -> Trunc m (T (Trunc_rec (n:=m) f)).
Proof.
  simple refine (Trunc_rec _).
  simple refine (T_rec _ _ _ _).
  intro a. exact (tr (t (tr a))).
  intros a b p; cbn. apply ap. apply tp. exact p.
  intros a; cbn.
  match goal with |[|- ap ?ff ?pp =_] => path_via (ap (x:=t (tr a)) ff 1) end.
  apply ap.
  apply (tp_1 (f:=Trunc_rec (n:=m) f) (tr a)).
Defined.

Lemma T_trunc_inv `{fs: Funext} (m:trunc_index) (A:Type) (B:TruncType m) (f:A -> B)
  : Trunc m (T (Trunc_rec (n:=m) f)) -> Trunc m (T f).
Proof.
  simple refine (Trunc_rec _).
  simple refine (T_rec _ _ _ _).
  simple refine (Trunc_rec _).
  intro a; exact (tr (t a)).
  simple refine (Trunc_ind _ _). intro a.
  simple refine (Trunc_ind _ _). intros b p.
  cbn in *.
  apply ap. apply tp. exact p.
  simple refine (Trunc_ind _ _).
  intro a. cbn.
  match goal with |[|- ap ?ff ?pp =_] => path_via (ap (x:=t a) ff 1) end.
  apply ap. apply tp_1.
Defined.

Lemma T_trunc_retr `{fs: Funext} (m:trunc_index) (A:Type) (B:TruncType m) (f:A -> B)
  : Sect (T_trunc_inv m A B f) (T_trunc_fun m A B f).
Proof.
  unfold T_trunc_inv, T_trunc_fun.
  simple refine (Trunc_ind _ _).
  simple refine (path_T _ _ _ _ _ _).
  simple refine (Trunc_ind _ _). intro a; reflexivity.
  simple refine (Trunc_ind _ _). intro a.
  simple refine (Trunc_ind _ _). intros b p.
  cbn in *.
  simple refine (concat_1p _ @ _). simple refine (_ @ (concat_p1 _)^).
  match goal with
  |[|- _ = ap (λ x, Trunc_rec ?ff (?gg x)) ?pp]
   => simple refine (_ @ (ap_compose gg (Trunc_rec ff) pp)^)
  end.
  match goal with
  |[|- _ = ap ?ff (ap (T_rec ?X1 ?X2 ?X3 ?X4) (tp ?aa ?bb ?pp)) ]
   => simple refine (_ @ (ap02 ff (T_rec_beta_tp X1 X2 X3 X4 aa bb pp)^))
  end. cbn.
  match goal with
  |[|- _ = ap ?ff (ap ?gg ?pp)]
   => simple refine (_ @ (ap_compose gg ff pp))
  end. cbn.
  match goal with
  |[|- _ = (ap (λ x, T_rec ?X1 ?X2 ?X3 ?X4 x) (tp ?aa ?bb ?pp)) ]
   => simple refine ((T_rec_beta_tp X1 X2 X3 X4 aa bb pp)^)
  end.

  simple refine (Trunc_ind _ _). cbn.
  intro a. rewrite transport_paths_FlFr.
  repeat rewrite ap_V. repeat rewrite inv_V.
  match goal with
  |[|- _ = (?pp @ 1) @ _]
   => rewrite (concat_p1 pp)
  end.
  repeat rewrite concat_p_pp. apply moveL_Mp.
  match goal with
  |[|- ?XX = _] => path_via (XX^^); apply ap
  end.
  match goal with
  |[|- _ = ap (λ x, ap ?ff x @ 1) ?pp] =>
   assert (rr: ap (λ x, ap ff x @ 1) pp = concat_p1 _ @ ap02 ff pp @ (concat_1p _)^)
  end.
  { rewrite concat_ap_Fpq.
    apply moveL_pV.
    apply moveL_Mp.
    rewrite concat_p_pp.
    match goal with
    |[|- (_ @ whiskerR ?hh _) @ _ = _]
     => pose (rew := whiskerR_p1 hh)
    end.
    cbn in *. rewrite rew; clear rew.
    rewrite ap02_is_ap. reflexivity. }
  rewrite rr; clear rr.
  do 4 rewrite inv_pp.
  do 3 rewrite inv_V.
  repeat rewrite concat_pp_p.
  apply whiskerL. cbn.
  rewrite concat_p1.
  rewrite ap02_V. rewrite inv_V.
  match goal with
  |[|- _ = ap02 (λ x, Trunc_rec ?ff (?gg x)) ?pp]
   => rewrite (ap02_compose _ _ _ gg (Trunc_rec ff) _ _ _ _ pp)
  end.
  apply whiskerL.
  rewrite T_rec_beta_tp_1. cbn. rewrite concat_p1.
  rewrite ap02_pp. apply whiskerL.
  rewrite ap02_pp. cbn. rewrite concat_p1.
  rewrite <- ap02_is_ap. apply moveR_Vp.
  match goal with
  |[|- _ = _ @ (ap02 ?ff (ap02 ?gg ?pp))] =>
   pose (rew := ap02_compose _ _ _ gg ff _ _ _ _ pp)
  end.
  cbn in rew. rewrite concat_p1 in rew. repeat rewrite concat_pp_p.
  rewrite <- rew; clear rew.
  rewrite T_rec_beta_tp_1. cbn.
  rewrite concat_ap_pFq.
  rewrite concat_V_pp. apply moveL_Mp. apply moveL_pM.
  match goal with
  |[|- (_ @ whiskerL _ ?hh) @ _ = _] => exact (whiskerL_1p hh)
  end.
Qed.

Lemma T_trunc_sect `{fs: Funext} (m:trunc_index) (A:Type) (B:TruncType m) (f:A -> B)
  : Sect (T_trunc_fun m A B f) (T_trunc_inv m A B f).
Proof.
  unfold T_trunc_fun, T_trunc_inv.
  simple refine (Trunc_ind _ _).
  simple refine (path_T _ _ _ _ _ _).
  intro a; reflexivity.
  intros a b p; cbn.
  simple refine (concat_1p _ @ _). simple refine (_ @ (concat_p1 _)^).
  match goal with
  |[|- _ = ap (λ x, Trunc_rec ?ff (?gg x)) ?pp]
   => simple refine (_ @ (ap_compose gg (Trunc_rec ff) pp)^)
  end.
  match goal with
  |[|- _ = ap ?ff (ap (T_rec ?X1 ?X2 ?X3 ?X4) (tp ?aa ?bb ?pp)) ]
   => simple refine (_ @ (ap02 ff (T_rec_beta_tp X1 X2 X3 X4 aa bb pp)^))
  end. cbn.
  match goal with
  |[|- _ = ap ?ff (ap ?gg ?pp)]
   => simple refine (_ @ (ap_compose gg ff pp))
  end. cbn.
  match goal with
  |[|- _ = (ap (λ x, T_rec ?X1 ?X2 ?X3 ?X4 x) (tp ?aa ?bb ?pp)) ]
   => simple refine ((T_rec_beta_tp X1 X2 X3 X4 aa bb pp)^)
  end.

  intro a. rewrite transport_paths_FlFr.
  repeat rewrite ap_V. repeat rewrite inv_V.
  cbn.
  match goal with
  |[|- _ = (?pp @ 1) @ _]
   => rewrite (concat_p1 pp)
  end.
  repeat rewrite concat_p_pp. apply moveL_Mp.
  match goal with
  |[|- ?XX = _] => path_via (XX^^); apply ap
  end.
  match goal with
  |[|- _ = ap (λ x, ap ?ff x @ 1) ?pp] =>
   assert (rr: ap (λ x, ap ff x @ 1) pp = concat_p1 _ @ ap02 ff pp @ (concat_1p _)^)
  end.
  { rewrite concat_ap_Fpq.
    apply moveL_pV.
    apply moveL_Mp.
    rewrite concat_p_pp.
    match goal with
    |[|- (_ @ whiskerR ?hh _) @ _ = _]
     => pose (rew := whiskerR_p1 hh)
    end.
    cbn in *. rewrite rew; clear rew.
    rewrite ap02_is_ap. reflexivity. }
  rewrite rr; clear rr.
  do 5 rewrite inv_pp.
  repeat rewrite inv_V.
  repeat rewrite concat_pp_p.
  apply whiskerL. cbn. rewrite concat_p1.
  rewrite ap02_V. rewrite inv_V.
  match goal with
  |[|- _ = ap02 (λ x, Trunc_rec ?ff (?gg x)) ?pp]
   => rewrite (ap02_compose _ _ _ gg (Trunc_rec ff) _ _ _ _ pp)
  end.
  apply whiskerL.
  rewrite T_rec_beta_tp_1. cbn. rewrite concat_p1.
  rewrite ap02_pp. apply whiskerL.
  rewrite ap02_pp. cbn. rewrite concat_p1.
  rewrite <- ap02_is_ap. apply moveR_Vp.
  match goal with
  |[|- _ = _ @ (ap02 ?ff (ap02 ?gg ?pp))] =>
   pose (rew := ap02_compose _ _ _ gg ff _ _ _ _ pp)
  end.
  cbn in rew. rewrite concat_p1 in rew. rewrite <- rew; clear rew.
  rewrite (T_rec_beta_tp_1 (f:= Trunc_rec f)).
  rewrite inv_pp. rewrite inv_V. rewrite concat_pp_p.
  apply whiskerL.
  rewrite concat_ap_pFq. apply moveL_pM.
  match goal with
  |[|- (_ @ whiskerL _ ?hh) @ _ = _] => exact (whiskerL_1p hh)
  end.
Qed.

Lemma T_trunc `{fs: Funext} (m:trunc_index) (A:Type) (B:TruncType m) (f:A -> B)
  : Trunc m (T f) <~> Trunc m (T (Trunc_rec (n:=m) f)).
Proof.
  simple refine (equiv_adjointify _ _ _ _).
  - apply T_trunc_fun.
  - apply T_trunc_inv.
  - apply T_trunc_retr.
  - apply T_trunc_sect.
Defined.

Definition T_equiv_fun `{ua: Univalence} {A B C:Type}
           (f: A -> B)
           (g: C -> B)
           (α: A -> C)
           (e: g o α = f)
  : T f -> T g.
Proof.
  simple refine (T_rec _ _ _ _).
  intro a; apply t. exact (α a).
  intros a b p; cbn.
  apply tp. exact (ap10 e a @ p @ (ap10 e b)^).
  intro a; cbn.
  path_via (tp (f:=g) (α a) (α a) 1).
  apply ap.
  simple refine ((concat_p1 _ @@ 1) @ _).
  apply concat_pV.
  apply tp_1.
Defined.

Definition isequiv_T_equiv_fun_path `{ua: Univalence} {A B C:Type}
           (f: A -> B)
           (g: C -> B)
           (α: A = C)
           (e: g o (equiv_path _ _ α) = f)
  : IsEquiv (T_equiv_fun f g (equiv_path _ _ α) e).
Proof.
  destruct α. cbn. destruct e.
  unfold T_equiv_fun; cbn.
  assert ((T_rec (T g) (λ a : A, t a)
        (λ (a b : A) (p : g a = g b), tp a b ((1 @ p) @ 1))
        (λ a : A, 1 @ tp_1 a)) == idmap).
  { simple refine (path_T _ _ _ _ _ _).
    intro; reflexivity.
    intros a b p; cbn.
    simple refine (concat_1p _ @ _ @ (concat_p1 _)^).
    simple refine (_ @ (T_rec_beta_tp _ _ _ _ _ _ _)^).
    simple refine (ap_idmap _ @ _).
    apply ap.
    simple refine (_ @ (concat_p1 _)^). exact (concat_1p _)^.
    intro a; cbn.
    rewrite transport_paths_FlFr. cbn.
    rewrite ap_V. rewrite inv_V.
    rewrite concat_ap_pFq.
    rewrite concat_ap_Fpq.
    apply moveR_pV.
    match goal with
    |[|- _ = ((?P1 @ _) @ ?P2) @ ?P3] =>
     rewrite (concat_p1 P1);
       rewrite (concat_pp_p _ _ P3)
    end.
    match goal with
    |[|- _ = _ @ (whiskerR ?hh 1 @ _) ]
     => pose (rew := whiskerR_p1 hh);
       rewrite concat_pp_p in rew;
       apply moveL_Vp in rew;
       rewrite rew; clear rew
    end.
    rewrite inv_V.
    apply moveR_Mp.
    match goal with
    |[|- _ = ?P1 @ ((whiskerL 1 ?hh) @ ?P3)] =>
     rewrite (concat_p_pp P1);
       pose (rew := whiskerL_1p hh);
       apply moveL_pV in rew;
       rewrite rew; clear rew
    end. cbn.
    repeat rewrite concat_p1; repeat rewrite concat_1p.
    rewrite <- (apD (λ U, ap_idmap U) (tp_1 a)^).
    rewrite transport_paths_FlFr. cbn. rewrite ap_V. rewrite inv_V.
    rewrite concat_p1.
    repeat rewrite concat_pp_p. apply whiskerL.
    repeat rewrite ap_V.
    rewrite <- (ap02_is_ap _ _ (T_rec (T g) (λ a0 : A, t a0)
            (λ (a0 b : A) (p : g a0 = g b), tp a0 b ((1 @ p) @ 1))
            (λ a0 : A, 1 @ tp_1 a0))).
    rewrite T_rec_beta_tp_1.
    rewrite ap_idmap. rewrite (concat_1p (tp_1 a)).
    rewrite inv_pp.  reflexivity. }
  simple refine (isequiv_homotopic idmap  _).
  exact (λ x, (X x)^).
Defined.

Definition isequiv_T_equiv_fun `{ua: Univalence} {A B C:Type}
           (f: A -> B)
           (g: C -> B)
           (α: A <~> C)
           (e: g o α = f)
  : IsEquiv (T_equiv_fun f g α e).
Proof.
  assert ((T_equiv_fun f g α e) = (T_equiv_fun f g (equiv_path _ _ (path_universe_uncurried α)) ((ap (λ u, g o u) (ap (@equiv_fun A C) (equiv_path_path_universe_uncurried α))) @ e))).
  { cbn.
    pose (ap (@equiv_fun A C) (equiv_path_path_universe_uncurried α)).
    pose (apD (λ U, T_equiv_fun f g U) p^).
    cbn in p0. rewrite <- p0. cbn.
    rewrite transport_arrow. rewrite transport_const.
    apply ap.
    cbn. rewrite transport_paths_Fl. apply moveL_Vp.
    rewrite inv_V. reflexivity. }
  simple refine (isequiv_homotopic _ (λ x, ap10 X^ x)).
  exact (isequiv_T_equiv_fun_path f g ((path_universe_uncurried α)) (ap (λ (u : A → C) (x : A), g (u x))
                                                                       (ap (equiv_fun (B:=C)) (equiv_path_path_universe_uncurried α)) @ e)).
Qed.


Require Import Basics.
Require Import Types.
Require Import Cubical.
Require Import HIT.Circle.

(* In this file we define the Torus as a HIT generated by two loops and
   a square between them. *)

Notation hr := (sq_refl_h _).
Notation vr := (sq_refl_v _).

Module Export Torus.

  Private Inductive Torus :=
    | tbase.

  Axiom loop_a : tbase = tbase.
  Axiom loop_b : tbase = tbase.
  Axiom surf : PathSquare loop_a loop_a loop_b loop_b.

  (* We define the induction principle for Torus *)
  Definition Torus_ind (P : Torus -> Type) (pb : P tbase)
    (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb)
    (ps : DPathSquare P surf pla pla plb plb) (x : Torus) : P x.
  Proof.
    by destruct x.
  Defined.

  (* We declare propsitional computational rules for loop_a and loop_b *)
  Axiom Torus_ind_beta_loop_a : forall (P : Torus -> Type) (pb : P tbase)
    (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb)
    (ps : DPathSquare P surf pla pla plb plb), DPathSquare P hr
      (dp_apD (Torus_ind P pb pla plb ps) (loop_a)) pla 1%dpath 1%dpath.

  Axiom Torus_ind_beta_loop_b : forall (P : Torus -> Type) (pb : P tbase)
    (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb)
    (ps : DPathSquare P surf pla pla plb plb), DPathSquare P hr
      (dp_apD (Torus_ind P pb pla plb ps) (loop_b)) plb 1%dpath 1%dpath.

  (* We write out the computation rule for surf even though we will not
     use it. Instead we currently have an unfinished recursion computation
     principle, but we don't currently know how to derive it from this *)
  Axiom Torus_ind_beta_surf : forall (P : Torus -> Type) (pb : P tbase)
    (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb)
    (ps : DPathSquare P surf pla pla plb plb),
      DPathCube P (cu_refl_lr _) (ds_apD (Torus_ind P pb pla plb ps) surf) ps
        (Torus_ind_beta_loop_a _ _ _ _ _) (Torus_ind_beta_loop_a _ _ _ _ _)
        (Torus_ind_beta_loop_b _ _ _ _ _) (Torus_ind_beta_loop_b _ _ _ _ _).

End Torus.

(* We can now define Torus recursion as a sepcial case of Torus induction *)
Definition Torus_rec (P : Type) (pb : P) (pla plb : pb = pb)
  (ps : PathSquare pla pla plb plb) : Torus -> P
  := Torus_ind _ pb (dp_const pla) (dp_const plb) (ds_const ps).

(* We can derive the recursion computation rules for Torus_rec *)
Lemma Torus_rec_beta_loop_a (P : Type) (pb : P) (pla plb : pb = pb)
  (ps : PathSquare pla pla plb plb)
  : PathSquare (ap (Torus_rec P pb pla plb ps) loop_a) pla 1 1.
Proof.
  refine (sq_GGcc _ (eissect _ _)
    (ds_const'^-1 (Torus_ind_beta_loop_a _ _ _ _ _))).
  apply moveR_equiv_V, dp_apD_const.
Defined.

Lemma Torus_rec_beta_loop_b (P : Type) (pb : P) (pla plb : pb = pb)
  (ps : PathSquare pla pla plb plb)
  : PathSquare (ap (Torus_rec P pb pla plb ps) loop_b) plb 1 1.
Proof.
  refine (sq_GGcc _ (eissect _ _)
    (ds_const'^-1 (Torus_ind_beta_loop_b _ _ _ _ _))).
  apply moveR_equiv_V, dp_apD_const.
Defined.

(* We ought to be able to prove this from Torus_ind_beta_surf
   but it is currently too difficult. Therefore we will leave it
   as admitted where it will simply look like an axiom. *)
Definition Torus_rec_beta_surf (P : Type) (pb : P) (pla plb : pb = pb)
  (ps : PathSquare pla pla plb plb)
  :  PathCube (sq_ap (Torus_rec P pb pla plb ps) surf) ps
      (Torus_rec_beta_loop_a P pb pla plb ps)
      (Torus_rec_beta_loop_a P pb pla plb ps)
      (Torus_rec_beta_loop_b P pb pla plb ps)
      (Torus_rec_beta_loop_b P pb pla plb ps).
Proof.
Admitted.

(** The torus is pointed. *)
Global Instance ispointed_torus : IsPointed Torus := tbase.

(* TODO:
(* We ought to be able to prove the computation rules all at the same time *)
(* This gives me the idea of writing all our computation rules as a
   "dependent filler" *)
Definition Torus_rec_beta_cube (P : Type) (pb : P) (pla plb : pb = pb)
  (ps : PathSquare pla pla plb plb)
  : { ba : PathSquare (ap (Torus_rec P pb pla plb ps) loop_a) pla 1 1 &
    { bb : PathSquare (ap (Torus_rec P pb pla plb ps) loop_b) plb 1 1 &
    PathCube (sq_ap (Torus_rec P pb pla plb ps) surf) ps ba ba bb bb}}.
Proof.
  refine (_;_;_).
  set
    (cu_cGcccc (eissect ds_const' _)
    (dc_const'^-1 (Torus_ind_beta_surf (fun _ => P) pb
    (dp_const pla) (dp_const plb) (ds_const' (sq_GGGG (eissect _ _)^ (eissect _ _)^ (eissect _ _)^ (eissect _ _)^ ps))))).
Admitted.
*)


Require Import List.
Require Import Omega.
Require Import Tactics.
Require Import Reflection.

Lemma skipn_length_gt : forall T (ls : list T) n,
  length ls <= n ->
  skipn n ls = nil.
Proof.
  induction ls; destruct n; simpl; intuition; auto. exfalso; omega.
Qed.

Lemma skipn_length_all : forall T U (F : T -> U) ls ls',
  map F ls = ls' ->
  skipn (length ls) ls' = nil.
Proof.
  intros. eapply skipn_length_gt. rewrite <- H. rewrite map_length. omega.
Qed.

Lemma rw_skipn_app : forall T (ls ls' : list T) n,
  length ls = n ->
  skipn n (ls ++ ls') = ls'.
Proof.
  clear. induction ls; destruct n; simpl in *; intros; auto; congruence.
Qed.
Lemma length_equal_map_rev : forall T U (F : T -> U) ls ls',
  map F ls' = rev ls ->
  length ls = length ls'.
Proof.
  clear. intros. rewrite <- rev_length. rewrite <- H. rewrite map_length. auto.
Qed.
Hint Resolve length_equal_map_rev : list_length.
Lemma eq_proves_gt : forall a b,
  a = b -> a <= b.
Proof.
  clear. intros; omega.
Qed.
Lemma map_length_hint : forall T U (F : T -> U) a b,
  map F a = b -> length b = length a.
Proof.
  clear. intros. subst. rewrite map_length. auto.
Qed.
Hint Resolve eq_proves_gt map_length_hint skipn_length_gt : list_length.

Hint Resolve skipn_length_all : list_length.
Hint Rewrite skipn_length_all using (eauto with list_length) : list_length.

Lemma nth_error_None_length : forall (T : Type) (ls : list T) (n : nat),
  nth_error ls n = None -> length ls <= n.
Proof.
  induction ls; destruct n; simpl; intros; think; try omega. inversion H.
  eapply IHls in H. omega.
Qed.

Lemma map_nth_error_full : forall T U (F : T -> U) ls n,
  nth_error (map F ls) n = match nth_error ls n with
                             | None => None
                             | Some v => Some (F v)
                           end.
Proof.
  induction ls; destruct n; simpl; intros; think; auto.
Qed.

Lemma app_len_2 : forall T (a b c d : list T),
  a ++ b = c ++ d ->
  length b = length d ->
  a = c /\ b = d.
Proof.
  clear. induction a; destruct c; simpl; intuition; subst; auto;
  simpl in *; try rewrite app_length in H0;
    try solve [ try generalize dependent (length d); intros; exfalso; omega ].
  inversion H. subst. f_equal. eapply IHa in H3; eauto. intuition.
  inversion H. eapply IHa in H3; intuition.
Qed.

Lemma not_sure : forall T U (F : T -> U) vars X,
  map F vars = X ->
  map F nil = skipn (length vars) X.
Proof.
  induction vars; intros; simpl in *; intros; auto. destruct X; auto.  eapply IHvars.
  inversion H. auto.
Qed.
Lemma map_skipn_all_map : forall T U (F : T -> U) ls,
  map F nil = skipn (length ls) (map F ls).
Proof.
  clear. induction ls; auto.
Qed.
Lemma map_skipn_all_map_is_nil : forall T U (F : T -> U) ls ls',
  map F ls' = skipn (length ls) (map F ls) ->
  ls' = nil.
Proof.
  clear; intros. rewrite <- map_skipn_all_map in H. destruct ls'; simpl in *; congruence.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall U V P A B C : Universe, ((wd_ U V /\ (wd_ U A /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (col_ U V P /\ (col_ U A B /\ (col_ U A C /\ col_ U B C)))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export Category.Core Functor.Core.
Require Import Common.

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

Section IdentityFunctor.
  (** There is an identity functor.  It does the obvious thing. *)
  Definition IdentityFunctor C : Functor C C
    := Build_Functor C C
                     (fun x => x)
                     (fun _ _ x => x)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End IdentityFunctor.

Notation "1" := (IdentityFunctor _) : functor_scope.


(** Proof Reflection in Coq ; objects.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export indices.

Set Implicit Arguments.

Section objects.

Variable l1 l2 : list nat.

Unset Elimination Schemes. (* Default trm_ind is useless *)

Inductive trm : Set :=
  | var : nat -> trm
  | fun_ : forall i : index l1, listn trm (select i) -> trm.

(*
trm_ind
     : (P:(trm->Prop))
        ((n:nat)(P (var n)))
        ->((i:(index l1); l:(listn trm (select_expl nat l1 i)))
            (P (fun l)))
        ->(t:trm)(P t)
*)

Definition trms := listn trm.
Definition emp := niln trm.

Section ip1.

Variable P : trm -> Prop.
Variable P0 : forall n : nat, trms n -> Prop.
Hypothesis h : forall n : nat, P (var n).
Hypothesis
  h0 :
    forall (i : index l1) (l : trms (select i)), P0 l -> P (fun_ i l).
Hypothesis h1 : P0 emp.
Hypothesis
  h2 :
    forall (n : nat) (t : trm),
    P t -> forall l : trms n, P0 l -> P0 (consn t l).

Fixpoint trm_ind' (t : trm) : P t :=
  match t as x return (P x) with
  | var n => h n
  | fun_ i l => h0 i (listn_ind P0 h1 (fun n0 t0 v0 h => h2 (trm_ind' t0) h) l)
  end.

End ip1.

Section ip2.

Variable P : trm -> Prop.
Let P0 (n : nat) (l : trms n) : Prop := forall t : trm, inn t l -> P t.
Hypothesis h : forall n : nat, P (var n).
Hypothesis
  h0 :
    forall (i : index l1) (l : trms (select i)), P0 l -> P (fun_ i l).
Let h1 : P0 emp := fun t => False_ind (P t).
Let h2 (n : nat) (t : trm) (d : P t) (l : trms n) (d0 : P0 l) :
  P0 (consn t l) :=
  fun u d1 =>
  or_ind (fun d2 : u = t => eq_ind_r (fun t0 => P t0) d d2)
    (fun d2 : inn u l => d0 u d2) d1.

Definition trm_ind := trm_ind' P P0 h h0 h1 h2.

End ip2.

Set Elimination Schemes.

Inductive frm : Set :=
  | top : frm
  | bot : frm
  | rel : forall i : index l2, trms (select i) -> frm
  | imp : frm -> frm -> frm
  | cnj : frm -> frm -> frm
  | dsj : frm -> frm -> frm
  | uvq : frm -> frm
  | exq : frm -> frm.

Inductive prf : Set :=
  | top_intro : prf
  | hyp : nat -> prf
  | bot_elim : prf -> frm -> prf
  | imp_intro : frm -> prf -> prf
  | imp_elim : prf -> prf -> prf
  | cnj_intro : prf -> prf -> prf
  | cnj_elim1 : prf -> prf
  | cnj_elim2 : prf -> prf
  | dsj_intro1 : frm -> prf -> prf
  | dsj_intro2 : frm -> prf -> prf
  | dsj_elim : prf -> prf -> prf -> prf
  | uvq_intro : prf -> prf
  | uvq_elim : trm -> prf -> prf
  | exq_intro : frm -> trm -> prf -> prf
  | exq_elim : prf -> prf -> prf.

Section map_trm_sec.

Variable g : nat -> nat -> nat.

Fixpoint map_trm (n : nat) (t : trm) {struct t} : trm :=
  match t with
  | var i => var (g n i)
  | fun_ i l => fun_ i (mapn (map_trm n) l)
  end.

End map_trm_sec.

Section map_var_sec.

Variable g : nat -> trm -> trm.

Fixpoint map_frm_var (n : nat) (p : frm) {struct p} : frm :=
  match p with
  | top => top
  | bot => bot
  | rel i l => rel i (mapn (g n) l)
  | imp q r => imp (map_frm_var n q) (map_frm_var n r)
  | cnj q r => cnj (map_frm_var n q) (map_frm_var n r)
  | dsj q r => dsj (map_frm_var n q) (map_frm_var n r)
  | uvq q => uvq (map_frm_var (S n) q)
  | exq q => exq (map_frm_var (S n) q)
  end.

Fixpoint map_prf_var (n : nat) (d : prf) {struct d} : prf :=
  match d with
  | top_intro => top_intro
  | hyp i => hyp i
  | bot_elim e p => bot_elim (map_prf_var n e) (map_frm_var n p)
  | imp_intro p e => imp_intro (map_frm_var n p) (map_prf_var n e)
  | imp_elim e f => imp_elim (map_prf_var n e) (map_prf_var n f)
  | cnj_intro e f => cnj_intro (map_prf_var n e) (map_prf_var n f)
  | cnj_elim1 e => cnj_elim1 (map_prf_var n e)
  | cnj_elim2 e => cnj_elim2 (map_prf_var n e)
  | dsj_intro1 p e => dsj_intro1 (map_frm_var n p) (map_prf_var n e)
  | dsj_intro2 p e => dsj_intro2 (map_frm_var n p) (map_prf_var n e)
  | dsj_elim e e1 e2 =>
      dsj_elim (map_prf_var n e) (map_prf_var n e1) (map_prf_var n e2)
  | uvq_intro e => uvq_intro (map_prf_var (S n) e)
  | uvq_elim t e => uvq_elim (g n t) (map_prf_var n e)
  | exq_intro p t e =>
      exq_intro (map_frm_var (S n) p) (g n t) (map_prf_var n e)
  | exq_elim e f => exq_elim (map_prf_var n e) (map_prf_var (S n) f)
  end.

End map_var_sec.

Section map_hyp_sec.

Variable g : nat -> nat -> nat.

Fixpoint map_prf_hyp (n : nat) (d : prf) {struct d} : prf :=
  match d with
  | top_intro => top_intro
  | hyp i => hyp (g n i)
  | bot_elim d p => bot_elim (map_prf_hyp n d) p
  | imp_intro p d => imp_intro p (map_prf_hyp (S n) d)
  | imp_elim d e => imp_elim (map_prf_hyp n d) (map_prf_hyp n e)
  | cnj_intro d e => cnj_intro (map_prf_hyp n d) (map_prf_hyp n e)
  | cnj_elim1 d => cnj_elim1 (map_prf_hyp n d)
  | cnj_elim2 d => cnj_elim2 (map_prf_hyp n d)
  | dsj_intro1 p d => dsj_intro1 p (map_prf_hyp n d)
  | dsj_intro2 p d => dsj_intro2 p (map_prf_hyp n d)
  | dsj_elim d e1 e2 =>
      dsj_elim (map_prf_hyp n d) (map_prf_hyp (S n) e1)
        (map_prf_hyp (S n) e2)
  | uvq_intro d => uvq_intro (map_prf_hyp n d)
  | uvq_elim t d => uvq_elim t (map_prf_hyp n d)
  | exq_intro p t d => exq_intro p t (map_prf_hyp n d)
  | exq_elim d e => exq_elim (map_prf_hyp n d) (map_prf_hyp (S n) e)
  end.

End map_hyp_sec.

Section boolpreds.

Fixpoint trm_eqb (t u : trm) {struct u} : bool :=
  match t, u with
  | var i, var j => nat_eqb i j
  | fun_ i l, fun_ j w => index_eqb l1 i j && listn_eqb trm_eqb l w
  | _, _ => false
  end.

Definition trms_eqb := listn_eqb trm_eqb.

Fixpoint frm_eqb (p q : frm) {struct q} : bool :=
  match p, q with
  | top, top => true
  | bot, bot => true
  | rel i l, rel j w => index_eqb l2 i j && trms_eqb l w
  | imp c d, imp e f => frm_eqb c e && frm_eqb d f
  | cnj c d, cnj e f => frm_eqb c e && frm_eqb d f
  | dsj c d, dsj e f => frm_eqb c e && frm_eqb d f
  | uvq c, uvq d => frm_eqb c d
  | exq c, exq d => frm_eqb c d
  | _, _ => false
  end.

Fixpoint free_inb_trm (n : nat) (t : trm) {struct t} : bool :=
  match t with
  | var m => nat_eqb n m
  | fun_ i l => mapn_orb (free_inb_trm n) l
  end.

Definition free_inb_trms (n k : nat) (l : trms k) :=
  mapn_orb (free_inb_trm n) l.

Fixpoint free_inb_frm (n : nat) (p : frm) {struct p} : bool :=
  match p with
  | top => false
  | bot => false
  | rel i l => free_inb_trms n l
  | imp q r => free_inb_frm n q || free_inb_frm n r
  | cnj q r => free_inb_frm n q || free_inb_frm n r
  | dsj q r => free_inb_frm n q || free_inb_frm n r
  | uvq q => free_inb_frm (S n) q
  | exq q => free_inb_frm (S n) q
  end.

End boolpreds.

End objects.

Notation Var := (var _) (only parsing).
Notation Top := (top _ _) (only parsing).
Notation Bot := (bot _ _) (only parsing).
Notation Hyp := (hyp _ _) (only parsing).
Notation Top_intro := (top_intro _ _) (only parsing).


Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".

Require Import Lists.List.
Import ListNotations.
Open Scope list.
From Utils Require Import Utils.

Section WithVar.
  Context (V : Type).

  Notation named_list := (@named_list V).
  Notation named_map := (@named_map V).

  (* Operations for types that can be substituted into themselves *)
  Class Substable0 (A : Type) : Type :=
    {
      inj_var : V -> A;
      apply_subst0 : named_list A -> A -> A;
      well_scoped0 : list V -> A -> Prop;
    }.

  Section WithSubstable0.
    Context {A} {Substable0 : Substable0 A}.

    Definition subst := (named_list A).

    Definition id_args {B} (c : named_list B) :=
      map inj_var (map fst c).

    (*Defined as a notation so that the definition
      does not get in the way of automation *)
    Notation id_subst c := (with_names_from c (id_args c)).

    Definition subst_cmp (s1 s2 : subst) := named_map (apply_subst0 s1) s2.

    Fixpoint ws_subst args (s : subst) : Prop :=
      match s with
      | [] => True
      | (n,e)::s' => fresh n s' /\ well_scoped0 args e /\ ws_subst args s'
      end.
    Arguments ws_subst args !s/.

    (* TODO: make sure that using apply_subst0 here isn't a problem for automation.
       The alternative is to split Substable into defs and properties like Substable0
     *)
    Definition args_subst s (a : list A) := map (apply_subst0 s) a.
    Arguments args_subst s !a/.

    Definition ws_args args : list A -> Prop := all (well_scoped0 args).
    Arguments ws_args args !s/.

    Class Substable0_ok : Type :=
      {
        (* Stated like this so that the class declaration doesn't depend on Eqb *)
        subst_var_internal : forall s x, named_list_lookup_prop (inj_var x) s x (apply_subst0 s (inj_var x));
        subst_assoc0 : forall s1 s2 a,
          well_scoped0 (map fst s2) a ->
          apply_subst0 s1 (apply_subst0 s2 a) = apply_subst0 (subst_cmp s1 s2) a;
        subst_id0 : forall {B} (c : named_list B) a,
          (* Not necessary because of our choice of default
        well_scoped (map fst c) a ->*)
          apply_subst0 (id_subst c) a = a;
        strengthen_subst0
        : forall s a n e,
          well_scoped0 (map fst s) a ->
          fresh n s ->
          apply_subst0 ((n,e)::s) a = apply_subst0 s a;
        well_scoped_subst0 args s a
        : ws_subst args s ->
          well_scoped0 (map fst s) a ->
          well_scoped0 args (apply_subst0 s a)
      }.

    Definition subst_lookup `{Eqb V} (s : subst) (n : V) : A :=
      named_list_lookup (inj_var n) s n.

    Arguments subst_lookup {_} !s n/.

    Lemma subst_var `{Eqb_ok V} `{Substable0_ok}
      : forall s x, apply_subst0 s (inj_var x) = subst_lookup s x.
    Proof.
      intros.
      unfold subst_lookup.
      symmetry.
      erewrite <- named_list_lookup_prop_correct.
      unshelve eapply subst_var_internal.
    Qed.

    Class Substable (B : Type) : Type :=
      {
        apply_subst : subst -> B -> B;
        well_scoped : list V -> B -> Prop;
      }.

    Class Substable_ok (B : Type) {Substable : Substable B} : Type :=
      {
        subst_assoc : forall s1 s2 a,
          well_scoped (map fst s2) a ->
          apply_subst s1 (apply_subst s2 a) = apply_subst (subst_cmp s1 s2) a;
        subst_id : forall {B} (c : named_list B) a,
          (* Not necessary because of our choice of default
        well_scoped (map fst c) a ->*)
          apply_subst (id_subst c) a = a;
        strengthen_subst
        : forall s a n e,
          well_scoped (map fst s) a ->
          fresh n s ->
          apply_subst ((n,e)::s) a= apply_subst s a;
        well_scoped_subst args s a
        : ws_subst args s ->
          well_scoped (map fst s) a ->
          well_scoped args (apply_subst s a)
      }.
    Arguments Substable_ok B%type_scope {Substable}.

    Notation "e [/ s /]" := (apply_subst s e) (at level 7, left associativity).

    #[export] Instance substable0_is_substable
      : Substable A :=
      {
        apply_subst := apply_subst0;
        well_scoped := well_scoped0;
      }.

    Context {Substable0_ok : Substable0_ok}.

    #[export] Instance substable0_is_substable_ok
      : Substable_ok A :=
      {
        subst_assoc :=  subst_assoc0;
        subst_id := @subst_id0 _;
        strengthen_subst := strengthen_subst0;
        well_scoped_subst := well_scoped_subst0;
      }.

    (*TODO: use separate DB*)
    Local Hint Rewrite subst_assoc0 : utils.
    Arguments subst_id0 {Substable0_ok} B%type_scope _ _.
    Local Hint Rewrite subst_id0 : utils.
    Local Hint Rewrite strengthen_subst0 : utils.
    Local Hint Resolve well_scoped_subst0 : utils.

    Lemma args_subst_assoc : forall s1 s2 a,
        ws_args (map fst s2) a ->
        args_subst s1 (args_subst s2 a)
        = args_subst (subst_cmp s1 s2) a.
    Proof.
      induction a; basic_goal_prep;
        basic_utils_crush.
    Qed.

    Lemma args_subst_id
      : forall A (c : named_list A) a,
        args_subst (id_subst c) a = a.
    Proof.
      induction a; basic_goal_prep;
        basic_utils_crush.
    Qed.

    Lemma args_strengthen_subst s a n e
      : ws_args (map fst s) a ->
        fresh n s ->
        args_subst ((n,e)::s) a = args_subst s a.
    Proof.
      induction a; basic_goal_prep; f_equal;
        basic_utils_crush.
    Qed.

    Lemma args_well_scoped_subst args s a
      : ws_subst args s ->
        ws_args (map fst s) a ->
        ws_args args (args_subst s a).
    Proof.
      induction a; basic_goal_prep; try case_match;
        basic_utils_crush.
    Qed.

    #[export] Instance substable_args : Substable (list A) :=
      {
        apply_subst := args_subst;
        well_scoped := ws_args;
      }.
    #[export] Instance substable_args_ok : Substable_ok (list A) :=
      {
        subst_assoc := args_subst_assoc;
        subst_id := args_subst_id;
        strengthen_subst := args_strengthen_subst;
        well_scoped_subst := args_well_scoped_subst;
      }.

    Lemma subst_subst_assoc : forall s1 s2 a,
        ws_subst (map fst s2) a ->
        subst_cmp s1 (subst_cmp s2 a)
        = subst_cmp (subst_cmp s1 s2) a.
    Proof.
      induction a; basic_goal_prep;
        basic_utils_crush.
    Qed.

    Lemma subst_subst_id
      : forall A (c : named_list A) a,
        subst_cmp (id_subst c) a = a.
    Proof.
      induction a; basic_goal_prep;
        basic_utils_crush.
    Qed.

    Lemma subst_strengthen_subst s a n e
      : ws_subst (map fst s) a ->
        fresh n s ->
        subst_cmp ((n,e)::s) a = subst_cmp s a.
    Proof.
      induction a; basic_goal_prep; f_equal;
        solve [basic_utils_crush].
    Qed.

    Lemma subst_well_scoped_subst args s a
      : ws_subst args s ->
        ws_subst (map fst s) a ->
        ws_subst args (subst_cmp s a).
    Proof.
      unfold subst_cmp.
      induction a; basic_goal_prep; try case_match;
        basic_utils_crush.
    Qed.

   #[export] Instance substable_subst : Substable (named_list A) :=
      {
        apply_subst := subst_cmp;
        well_scoped := ws_subst;
      }.

   #[export] Instance substable_subst_ok : Substable_ok (named_list A) :=
      {
        subst_assoc := subst_subst_assoc;
        subst_id := subst_subst_id;
        strengthen_subst := subst_strengthen_subst;
        well_scoped_subst := subst_well_scoped_subst;
      }.

    Lemma with_names_from_args_subst {B} (c':named_list B) s' (s : list A)
      : with_names_from c' s[/s'/] = (with_names_from c' s)[/s'/].
    Proof.
      revert s.
      induction c';
        destruct s;
        basic_goal_prep;
        basic_utils_crush.
    Qed.

  End WithSubstable0.

End WithVar.

Arguments id_args : simpl never.

(*Defined as a notation so that the definition
does not get in the way of automation *)
Notation id_subst c := (with_names_from c (id_args c)).

Arguments subst_lookup [V]%type_scope {A}%type_scope {Substable0 H} !s n/.
Arguments args_subst [V]%type_scope {A}%type_scope {Substable0} s !a%list_scope/.
Arguments ws_args [V]%type_scope {A}%type_scope {Substable0} (_ !_)%list_scope/.

Arguments ws_subst [V]%type_scope {A}%type_scope {Substable0} args !s/.

Arguments Substable0_ok [V]%type_scope _%type_scope {_}.
Arguments Substable [V]%type_scope A%type_scope _%type_scope.
Arguments Substable_ok [V]%type_scope A%type_scope {Substable0} B%type_scope {Substable}.

Arguments well_scoped [V]%type_scope {A B}%type_scope {_} _%list_scope !_.
Arguments apply_subst [V]%type_scope {A B}%type_scope {_} _%list_scope !_.

Arguments args_subst [V]%type_scope {A}%type_scope {Substable0} s !a%list_scope/.
Arguments ws_args [V]%type_scope {A}%type_scope {Substable0} (_ !_)%list_scope/.
Arguments subst_id0 [V]%type_scope {A}%type_scope {Substable0 Substable0_ok} B%type_scope _ _ : rename.

#[global] Hint Rewrite subst_assoc using solve[typeclasses eauto] : term.
#[global] Hint Rewrite subst_id using solve[typeclasses eauto] : term.
#[global] Hint Rewrite strengthen_subst using solve[typeclasses eauto] : term.
#[global] Hint Resolve well_scoped_subst : term.

Notation "e [/ s /]" := (apply_subst s e) (at level 7, left associativity).


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

(**********************************************************************)
(*                    Tree_Normal.v                                   *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.

Inductive status_val :=
| Active : status_val
| Passive : status_val
.

Fixpoint status M :=
match M with
| Ref _ => Active
| Op _ => Passive
| App (App (App (Op Node) M1) _ ) _ => status M1
| App M1 _ => status M1
end.

(* normal terms *)

Inductive normal : Tree -> Prop :=
| nf_ref : forall n, normal (Ref n)
| nf_op : forall o, normal (Op o)
| nf_active : forall M1 M2, normal M1 -> normal M2 ->
                              status (App M1 M2) = Active ->
                              normal (App M1 M2)
| nf_compound : forall M1 M2, normal M1 -> normal M2 ->
                              compound (App M1 M2) -> normal (App M1 M2)
.

Hint Constructors normal.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma ref_irreducible : forall n, irreducible (Ref n) sf_seqred1.
Proof. intro n. red. split_all. inversion H; auto. Qed.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M sf_seqred1.
Proof.
intros M nor; induction nor; split_all.
(* 4 *)
eapply2 ref_irreducible.
(* 3 *)
red; split_all. inversion H.
(* 2 *)
intro. intro. inversion H0; subst; simpl in *; try discriminate.
(* 4 *)
eapply2 IHnor1.
(* 3 *)
eapply2 IHnor2.
(* 1 *)
intro. intro. inversion H0; subst; simpl in *; try (inversion H; fail).
eapply2 IHnor1.
eapply2 IHnor2.
Qed.

Theorem Tree_progress : forall (M : Tree), normal M \/ (exists N, sf_seqred1 M N) .
Proof.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 1 *)
inversion IHM1; split_all. 2: right; inversion H; exist (App x M2).
inversion IHM2; split_all.  2:right; inversion H0; exist (App M1 x).
gen_case H M1. case o; try (right; eauto; fail); left; auto.
inversion H; subst.
(* 2 *)
left; auto.
eapply2 nf_active. gen_case H5 t. gen_case H5 t1. discriminate.
(* 1 *)
gen2_case H3 H5 t.
left; case o; auto.
gen2_case H3 H5 t1.
gen2_case H3 H5 o; try (right; eauto; fail).
inversion H3; subst. inversion H8.
inversion H7; subst. left; eapply2 nf_active.
right; eauto. left; eapply2 nf_active.
right; eauto. inversion H5.
(* 2 *)
inversion H9; subst; eauto.
(* 1 *)
inversion H5.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*   Assia.Mahboubi@inria.fr, Laurence.Rideau@inria.fr       *)
(*  Laurent.Thery@inria.fr  &all    Inria, 2006              *)
(*************************************************************)

Unset Boxed Definitions.
Unset Boxed Values.

Require Export ZArith.
Require Export Mylist.
Require Import Setoid.
Require Import Utils.

Definition Is_true (b:bool) : Prop:=
match b with
|true => True
|false => False
end.

(*in order to test the efficency, depending to when the reduction of
  rationnals is performed*)

 Module Type RAT_STRUCT.

   Parameter Rat : Set.

   Bind Scope rscope with Rat.
   Open Scope rscope.

(*constants, operations over rationnals,
-MkRat builds a rationnal number from an integer and a positive
-RatEq is an eq relation over rationnals
-rzero_test is a decidable test to the zero constant
-rsign gives the sign of a rationnal : Z0 means it is zero, Zpos _, it is pos, ...
-rpow builds a power of a rationnal, if the rat argument is
  normalized then the power is normalized
*)

   Parameter  r0 : Rat.
   Parameter  r1 : Rat.
   Parameter  MkRat : Z -> positive -> Rat.
   Parameter  Norm : Rat -> Rat.
   Parameter  radd : Rat -> Rat -> Rat.
   Parameter  ropp : Rat -> Rat.
   Parameter  rprod : Rat -> Rat -> Rat.
   Parameter  rsub : Rat -> Rat -> Rat.
   Parameter  rinv : Rat -> Rat.
   Parameter  rdiv : Rat -> Rat -> Rat.
   Parameter  RatEq : Rat -> Rat -> Prop.
   Parameter  rzero_test : Rat -> bool.
   Parameter  rlt : Rat -> Rat -> bool.
   Parameter  rsign : Rat -> comparison.
   Parameter  rpow : Rat -> N -> Rat.
   Parameter  rabs_val : Rat -> Rat.

   Notation "a # b" := (MkRat a b)(at level 20, no associativity) : rscope.

   Infix "+r" := radd(at level 50, left associativity) :rscope.
   Notation "-r x" := (ropp x)(at level 50, left associativity) : rscope.
   Infix  "*r" := rprod(at level 40, left associativity) : rscope.
   Infix "-r" := rsub(at level 35, right associativity) : rscope.
   Notation "/r x" := (rinv x)(at level 40, left associativity) : rscope.
   Infix "/r":= rdiv(at level 35, right associativity) : rscope.

   Notation "x == y" := (RatEq x y)(at level 70, no associativity) : rscope.

 Open Scope rscope.

 End RAT_STRUCT.

 Module RAT_FUNS(Q:RAT_STRUCT).

   Import Q.
   Definition rof_Z(x : Z) := (MkRat x 1).
   Definition rof_pos(i:positive) := (rof_Z (Zpos i)).
   Definition rof_N(n:N):=
     match n with
       |N0 => r0
       |Npos p => (rof_pos p)
     end.

 Definition fact'(n m:positive):positive:=  ((Psucc n)*m)%positive.

 Definition rfact(n:N):=
   match n with
     |N0 => r1
     |Npos p => rof_pos (Prec positive xH fact' p)
   end.

   (*binomial coefficient C(n,p)*)(*pareil,c'est surement ameliorable*)
 Definition rbinomial(n p:N):Rat:=
   match Ncompare n p with
     |Eq => r1
     |Lt => r1 (*should nt happen!*)
     |Gt => (rfact n) /r ((rfact p) *r (rfact (Nminus n  p)))
   end.

 Fixpoint rmax_list(l:list Rat):Rat:=
   match l with
     |nil => r0
     |r::l' =>
       match l' with
	 |nil => r
	 |_ =>
	   let m:= rmax_list l' in
	     if rlt r m
	       then m
	       else r
       end
   end.

 Fixpoint rmin_list(l:list Rat):Rat:=
   match l with
     |nil => r0
     |r::l' =>
       match l' with
	 |nil => r
	 |_ =>
	   let m:= rmin_list l' in
	     if rlt r m
	       then r
	       else m
       end
   end.

 Definition rle(q q':Rat) := orb (rlt q q') (rzero_test (q -r q')).

 Definition rmin(q q':Rat):=
   if rle q q' then q else q'.

 Definition rmax(q q':Rat):=
   if rle q q' then q' else q.

   End RAT_FUNS.

Module RAT_INT_OPS(Q:RAT_STRUCT).
Module QFUNS := RAT_FUNS Q.
Import Q.
Import QFUNS.

Definition req(r r':Rat):=rzero_test (rsub r r').

Definition rmin4(a b c d:Rat):=
rmin a (rmin b (rmin c d)).

Definition rmax4(a b c d:Rat):=
rmax a (rmax b (rmax c d)).

(* Very naive interval arithmetic for bound computations *)

(* [a,b]+[c,d], a<=b and c<=d *)
Definition radd_int(a b c d:Rat):=((radd a c), (radd b d)).

(* [a,b]*[c,d], a<=b and c<=d *)
Definition rprod_int(a b c d:Rat):=
((rmin4 (rprod a c) (rprod a d) (rprod b c) (rprod b d)),
(rmax4 (rprod a c) (rprod a d) (rprod b c) (rprod b d))).

(*[a,b]^i, a<=b*)
Definition rpow_int_pos:=
fix ipow(a b:Rat)(i:positive){struct i}:Rat*Rat:=
          match i with
	|xH => (a,b)
	|xO p => let (c,d) := ipow a b p in rprod_int c d c d
	|xI p =>
	let (c,d) := ipow a b p in
	let (c',d') := (rprod_int c d c d) in
	rprod_int c' d' a b
	end.

Definition rpow_int(a b:Rat)(n:N):=
 match n with
  |N0 => (r1,r1)
  |Npos p =>rpow_int_pos a b p
end.

Definition rdiv_int(a b c d:Rat):=
(rmin4 (rdiv a c) (rdiv a b) (rdiv b c)  (rdiv b d),
rmax4 (rdiv a c) (rdiv a b) (rdiv b c)  (rdiv b d)).

End RAT_INT_OPS.


Set Implicit Arguments.

Require Import List.
Require Import Bvector.
Require Import HMAC_common_defs.
Require Import SHA256.
Require Import HMAC_spec_pad.
Require Import Coq.Program.Basics.
Require Import Coqlib.
Require Import ByteBitRelations.
Require Import sha_padding_lemmas.

Module HMAC_Concat.

Section HMAC.

  Variable c p : nat.
  Definition b := (c + p)%nat.

  (* The compression function *)
  Variable h : Blist -> Blist -> Blist.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Blist.

  (* splitAndPad concat'ed, normal fold replaced by firstn/splitn manual fold *)

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

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

  (* fpad can be a constant *)
  Variable fpad : Blist -> Blist.
  Definition app_fpad (x : Blist) : Blist :=
    x ++ fpad x.

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitList c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Blist) m :=
    let (k_Out, k_In) := splitList b k in
      let h_in := (hash_words (k_In ++ m)) in
        hash_words (k_Out ++ app_fpad h_in).

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

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

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

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

End HMAC.

End HMAC_Concat.

Lemma h_star_eq :
  HMAC_Pad.h_star = HMAC_Concat.h_star.
Proof. reflexivity. Qed.

(* TODO add assumptions, prove, prove assumptions where used, and move to ByteBitRelations *)

Lemma bitsToBytes_len : forall (l : Blist),
                          True ->
                          Zlength (bitsToBytes l) = BlockSize.
Proof.

Admitted.

Lemma bitsToBytes_app : forall (l m : Blist),
                          True ->
                          True ->
                          bitsToBytes (l ++ m) = bitsToBytes l ++ bitsToBytes m.
Proof.

Admitted.

Lemma bits_bytes_bits_id : forall (l : Blist),
                             True ->
                             bytesToBits (bitsToBytes l) = l.
Proof.

Admitted.

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

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

  apply bitsToBytes_len.
    admit.
  apply bitsToBytes_len.
    admit.
  apply bitsToBytes_len.
    admit.
  admit.
  admit.
  admit.
Qed.

Lemma fpad_eq : forall (l m : Blist),
                  length l = b ->
                  (* TODO m is in blocks *)
                  sha_splitandpad (l ++ m) = l ++ HMAC_Concat.app_fpad fpad m.
Proof.
  intros l m len.
  unfold HMAC_Concat.app_fpad.
  unfold sha_splitandpad. unfold fpad.
  unfold pad. unfold fpad_inner.

  rewrite -> bitsToBytes_app.
  repeat rewrite -> bytesToBits_app.
  repeat rewrite -> bits_bytes_bits_id.
  rewrite <- app_assoc.
  rewrite -> common_lemmas.Zlength_app.
  repeat f_equal.

  apply bitsToBytes_len.
    admit.
  apply bitsToBytes_len.
    admit.
  apply bitsToBytes_len.
    admit.
  admit.
  admit.
  admit.
  admit.
Qed.

Theorem HMAC_concat_pad : forall (k m : Blist) (op ip : Blist),
                            (* TODO length guarantees on k, ip, and op *)
  HMAC_Pad.HMAC c p sha_h sha_iv sha_splitandpad op ip k m =
  HMAC_Concat.HMAC c p sha_h sha_iv sha_splitandpad_inc fpad op ip k m.
Proof.
  intros k m op ip.
  unfold c, p in *. simpl in *.
  unfold HMAC_Pad.HMAC. unfold HMAC_Concat.HMAC.
  unfold HMAC_Pad.HMAC_2K. unfold HMAC_Concat.HMAC_2K.
  unfold HMAC_Pad.GHMAC_2K. unfold HMAC_Concat.GHMAC_2K.

  repeat rewrite -> split_append_id.
  unfold HMAC_Pad.hash_words_padded. unfold compose.
  unfold HMAC_Concat.hash_words.
  unfold HMAC_Pad.hash_words.
  rewrite -> h_star_eq.

  (* show the two inputs to h_star are equal *)
  f_equal.

  rewrite <- splitandpad_eq.
  rewrite <- fpad_eq.
  reflexivity.

(* TODO split out lemma that BLxor preserves length given 2 of block size *)
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
Qed.


From stdpp Require Import gmap.
From iris.base_logic Require Export base_logic big_op.
Set Default Proof Using "Type".
Import uPred.

Module uPred_reflection. Section uPred_reflection.
  Context {M : ucmraT}.

  Inductive expr :=
    | ETrue : expr
    | EVar : nat → expr
    | ESep : expr → expr → expr.
  Fixpoint eval (Σ : list (uPred M)) (e : expr) : uPred M :=
    match e with
    | ETrue => True
    | EVar n => from_option id True%I (Σ !! n)
    | ESep e1 e2 => eval Σ e1 ∗ eval Σ e2
    end.
  Fixpoint flatten (e : expr) : list nat :=
    match e with
    | ETrue => []
    | EVar n => [n]
    | ESep e1 e2 => flatten e1 ++ flatten e2
    end.

  Notation eval_list Σ l := ([∗ list] n ∈ l, from_option id True (Σ !! n))%I.

  Lemma eval_flatten Σ e : eval Σ e ⊣⊢ eval_list Σ (flatten e).
  Proof.
    induction e as [| |e1 IH1 e2 IH2];
      rewrite /= ?right_id ?big_opL_app ?IH1 ?IH2 //.
  Qed.
  Lemma flatten_entails Σ e1 e2 :
    flatten e2 ⊆+ flatten e1 → eval Σ e1 ⊢ eval Σ e2.
  Proof. intros. rewrite !eval_flatten. by apply big_sepL_submseteq. Qed.
  Lemma flatten_equiv Σ e1 e2 :
    flatten e2 ≡ₚ flatten e1 → eval Σ e1 ⊣⊢ eval Σ e2.
  Proof. intros He. by rewrite !eval_flatten He. Qed.

  Fixpoint prune (e : expr) : expr :=
    match e with
    | ETrue => ETrue
    | EVar n => EVar n
    | ESep e1 e2 =>
       match prune e1, prune e2 with
       | ETrue, e2' => e2'
       | e1', ETrue => e1'
       | e1', e2' => ESep e1' e2'
       end
    end.
  Lemma flatten_prune e : flatten (prune e) = flatten e.
  Proof.
    induction e as [| |e1 IH1 e2 IH2]; simplify_eq/=; auto.
    rewrite -IH1 -IH2. by repeat case_match; rewrite ?right_id_L.
  Qed.
  Lemma prune_correct Σ e : eval Σ (prune e) ⊣⊢ eval Σ e.
  Proof. by rewrite !eval_flatten flatten_prune. Qed.

  Fixpoint cancel_go (n : nat) (e : expr) : option expr :=
    match e with
    | ETrue => None
    | EVar n' => if decide (n = n') then Some ETrue else None
    | ESep e1 e2 =>
       match cancel_go n e1 with
       | Some e1' => Some (ESep e1' e2)
       | None => ESep e1 <$> cancel_go n e2
       end
    end.
  Definition cancel (ns : list nat) (e: expr) : option expr :=
    prune <$> fold_right (mbind ∘ cancel_go) (Some e) ns.
  Lemma flatten_cancel_go e e' n :
    cancel_go n e = Some e' → flatten e ≡ₚ n :: flatten e'.
  Proof.
    revert e'; induction e as [| |e1 IH1 e2 IH2]; intros;
      repeat (simplify_option_eq || case_match); auto.
    - by rewrite IH1 //.
    - by rewrite IH2 // Permutation_middle.
  Qed.
  Lemma flatten_cancel e e' ns :
    cancel ns e = Some e' → flatten e ≡ₚ ns ++ flatten e'.
  Proof.
    rewrite /cancel fmap_Some=> -[{e'}e' [He ->]]; rewrite flatten_prune.
    revert e' He; induction ns as [|n ns IH]=> e' He; simplify_option_eq; auto.
    rewrite Permutation_middle -flatten_cancel_go //; eauto.
  Qed.
  Lemma cancel_entails Σ e1 e2 e1' e2' ns :
    cancel ns e1 = Some e1' → cancel ns e2 = Some e2' →
    (eval Σ e1' ⊢ eval Σ e2') → eval Σ e1 ⊢ eval Σ e2.
  Proof.
    intros ??. rewrite !eval_flatten.
    rewrite (flatten_cancel e1 e1' ns) // (flatten_cancel e2 e2' ns) //; csimpl.
    rewrite !big_opL_app. apply sep_mono_r.
  Qed.

  Fixpoint to_expr (l : list nat) : expr :=
    match l with
    | [] => ETrue
    | [n] => EVar n
    | n :: l => ESep (EVar n) (to_expr l)
    end.
  Arguments to_expr !_ / : simpl nomatch.
  Lemma eval_to_expr Σ l : eval Σ (to_expr l) ⊣⊢ eval_list Σ l.
  Proof.
    induction l as [|n1 [|n2 l] IH]; csimpl; rewrite ?right_id //.
    by rewrite IH.
  Qed.

  Lemma split_l Σ e ns e' :
    cancel ns e = Some e' → eval Σ e ⊣⊢ (eval Σ (to_expr ns) ∗ eval Σ e').
  Proof.
    intros He%flatten_cancel.
    by rewrite eval_flatten He big_opL_app eval_to_expr eval_flatten.
  Qed.
  Lemma split_r Σ e ns e' :
    cancel ns e = Some e' → eval Σ e ⊣⊢ (eval Σ e' ∗ eval Σ (to_expr ns)).
  Proof. intros. rewrite /= comm. by apply split_l. Qed.

  Class Quote (Σ1 Σ2 : list (uPred M)) (P : uPred M) (e : expr) := {}.
  Global Instance quote_True Σ : Quote Σ Σ True ETrue.
  Global Instance quote_var Σ1 Σ2 P i:
    rlist.QuoteLookup Σ1 Σ2 P i → Quote Σ1 Σ2 P (EVar i) | 1000.
  Global Instance quote_sep Σ1 Σ2 Σ3 P1 P2 e1 e2 :
    Quote Σ1 Σ2 P1 e1 → Quote Σ2 Σ3 P2 e2 → Quote Σ1 Σ3 (P1 ∗ P2) (ESep e1 e2).

  Class QuoteArgs (Σ: list (uPred M)) (Ps: list (uPred M)) (ns: list nat) := {}.
  Global Instance quote_args_nil Σ : QuoteArgs Σ nil nil.
  Global Instance quote_args_cons Σ Ps P ns n :
    rlist.QuoteLookup Σ Σ P n →
    QuoteArgs Σ Ps ns → QuoteArgs Σ (P :: Ps) (n :: ns).
  End uPred_reflection.

  Ltac quote :=
    match goal with
    | |- ?P1 ⊢ ?P2 =>
      lazymatch type of (_ : Quote [] _ P1 _) with Quote _ ?Σ2 _ ?e1 =>
      lazymatch type of (_ : Quote Σ2 _ P2 _) with Quote _ ?Σ3 _ ?e2 =>
        change (eval Σ3 e1 ⊢ eval Σ3 e2) end end
    end.
  Ltac quote_l :=
    match goal with
    | |- ?P1 ⊢ ?P2 =>
      lazymatch type of (_ : Quote [] _ P1 _) with Quote _ ?Σ2 _ ?e1 =>
        change (eval Σ2 e1 ⊢ P2) end
    end.
End uPred_reflection.

Tactic Notation "solve_sep_entails" :=
  uPred_reflection.quote; apply uPred_reflection.flatten_entails;
  apply (bool_decide_unpack _); vm_compute; exact Logic.I.

Ltac close_uPreds Ps tac :=
  let M := match goal with |- @uPred_entails ?M _ _ => M end in
  let rec go Ps Qs :=
    lazymatch Ps with
    | [] => let Qs' := eval cbv [reverse rev_append] in (reverse Qs) in tac Qs'
    | ?P :: ?Ps => find_pat P ltac:(fun Q => go Ps (Q :: Qs))
    end in
  (* avoid evars in case Ps = @nil ?A *)
  try match Ps with [] => unify Ps (@nil (uPred M)) end;
  go Ps (@nil (uPred M)).

Tactic Notation "cancel" constr(Ps) :=
  uPred_reflection.quote;
  let Σ := match goal with |- uPred_reflection.eval ?Σ _ ⊢ _ => Σ end in
  let ns' := lazymatch type of (_ : uPred_reflection.QuoteArgs Σ Ps _) with
             | uPred_reflection.QuoteArgs _ _ ?ns' => ns'
             end in
  eapply uPred_reflection.cancel_entails with (ns:=ns');
    [cbv; reflexivity|cbv; reflexivity|simpl].

Tactic Notation "ecancel" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Qs => cancel Qs).

(** [to_front [P1, P2, ..]] rewrites in the premise of ⊢ such that
    the assumptions P1, P2, ... appear at the front, in that order. *)
Tactic Notation "to_front" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Ps =>
    uPred_reflection.quote_l;
    let Σ := match goal with |- uPred_reflection.eval ?Σ _ ⊢ _ => Σ end in
    let ns' := lazymatch type of (_ : uPred_reflection.QuoteArgs Σ Ps _) with
               | uPred_reflection.QuoteArgs _ _ ?ns' => ns'
               end in
    eapply entails_equiv_l;
      first (apply uPred_reflection.split_l with (ns:=ns'); cbv; reflexivity);
      simpl).

Tactic Notation "to_back" open_constr(Ps) :=
  close_uPreds Ps ltac:(fun Ps =>
    uPred_reflection.quote_l;
    let Σ := match goal with |- uPred_reflection.eval ?Σ _ ⊢ _ => Σ end in
    let ns' := lazymatch type of (_ : uPred_reflection.QuoteArgs Σ Ps _) with
               | uPred_reflection.QuoteArgs _ _ ?ns' => ns'
               end in
    eapply entails_equiv_l;
      first (apply uPred_reflection.split_r with (ns:=ns'); cbv; reflexivity);
      simpl).

(** [sep_split] is used to introduce a (∗).
    Use [sep_split left: [P1, P2, ...]] to define which assertions will be
    taken to the left; the rest will be available on the right.
    [sep_split right: [P1, P2, ...]] works the other way around. *)
Tactic Notation "sep_split" "right:" open_constr(Ps) :=
  to_back Ps; apply sep_mono.
Tactic Notation "sep_split" "left:" open_constr(Ps) :=
  to_front Ps; apply sep_mono.


(** This file defines [Algebra]. *)

Require Export
  Coq.Unicode.Utf8
  HoTT.Basics.Overture
  HoTT.Basics.Trunc
  HoTTClasses.implementations.ne_list
  HoTTClasses.implementations.family_prod.

Require Import
  HoTT.Basics.Equivalences
  HoTT.Types.Record
  HoTT.Types.Sigma
  HoTT.Types.Arrow
  HoTT.Types.Forall
  HoTT.Types.Universe
  HoTT.HSet
  HoTTClasses.implementations.list.

Import ne_list.notations.

Declare Scope Algebra_scope.

Delimit Scope Algebra_scope with Algebra.

Open Scope Algebra_scope.

Definition SymbolType_internal : Type → Type := ne_list.

(** A [Signature] is used to characterise [Algebra]s. In particular
    a signature specifies which operations (functions) an algebra for
    the signature is expected to provide. A signature consists of
    - A type of [Sort]s. An algebra for the signature must provide
      a type for each [s : Sort].
    - A type of function symbols [Symbol]. For each function symbol
      [u : Symbol], an algebra for the signature must provide a
      corresponding operation.
    - The field [symbol_types σ u] indicates which type the operation
      corresponding to [u] should have. *)

Record Signature : Type := BuildSignature
  { Sort : Type
  ; Symbol : Type
  ; symbol_types : Symbol → SymbolType_internal Sort }.

(** We have this implicit coercion allowing us to use a signature
    [σ:Signature] as a map [Symbol σ → SymbolType σ]
    (see [SymbolType] below). *)

Global Coercion symbol_types : Signature >-> Funclass.

(** A single sorted [Signature] is a signature with [Sort = Unit]. *)

Definition BuildSingleSortedSignature (sym : Type) (arities : sym → nat)
  : Signature
  := BuildSignature Unit sym (ne_list.replicate_Sn tt o arities).

(** Let [σ:Signature]. For each symbol [u : Symbol σ], [σ u]
    associates [u] to a [SymbolType σ]. This represents the required
    type of the algebra operation corresponding to [u]. *)

Definition SymbolType (σ : Signature) : Type := ne_list (Sort σ).

(** For [s : SymbolType σ], [cod_symboltype σ] is the codomain of the
    symbol type [s]. *)

Definition cod_symboltype {σ} : SymbolType σ → Sort σ
  := ne_list.last.

(** For [s : SymbolType σ], [cod_symboltype σ] is the domain of the
    symbol type [s]. *)

Definition dom_symboltype {σ} : SymbolType σ → list (Sort σ)
  := ne_list.front.

(** For [s : SymbolType σ], [cod_symboltype σ] is the arity of the
    symbol type [s]. That is the number [n:nat] of arguments of the
    [SymbolType σ]. *)

Definition arity_symboltype {σ} : SymbolType σ → nat
  := length o dom_symboltype.

(** An [Algebra] must provide a family of [Carriers σ] indexed by
    [Sort σ]. These carriers are the "objects" (types) of the algebra. *)

(* [Carriers] is a notation because it will be used for an implicit
   coercion [Algebra >-> Funclass] below. *)

Notation Carriers σ := (Sort σ → Type).

(** The function [Operation] maps a family of carriers [A : Carriers σ]
    and [w : SymbolType σ] to the corresponding function type.

    <<
      Operation A [:s1; s2; ...; sn; t:] = A s1 → A s2 → ... → A sn → A t
    >>

    where [[:s1; s2; ...; sn; t:] : SymbolType σ] is a symbol type
    with domain [[s1; s2; ...; sn]] and codomain [t]. *)

Fixpoint Operation {σ} (A : Carriers σ) (w : SymbolType σ) : Type
  := match w with
     | [:s:] => A s
     | s ::: w' => A s → Operation A w'
     end.

Global Instance trunc_operation `{Funext} {σ : Signature}
  (A : Carriers σ) {n} `{!∀ s, IsTrunc n (A s)} (w : SymbolType σ)
  : IsTrunc n (Operation A w).
Proof.
  induction w; apply (istrunc_trunctype_type (BuildTruncType n _)).
Defined.

(** Uncurry of an [f : Operation A w], such that

    <<
      ap_operation f (x1,x2,...,xn) = f x1 x2 ... xn
    >>
*)

Fixpoint ap_operation {σ} {A : Carriers σ} {w : SymbolType σ}
    : Operation A w →
      FamilyProd A (dom_symboltype w) →
      A (cod_symboltype w)
    := match w with
       | [:s:] => λ f _, f
       | s ::: w' => λ f '(x, l), ap_operation (f x) l
       end.

(** Funext for uncurried [Operation A w]. If

    <<
      ap_operation f (x1,x2,...,xn) = ap_operation g (x1,x2,...,xn)
    >>

    for all [(x1,x2,...,xn) : A s1 * A s2 * ... * A sn], then [f = g]. *)

Fixpoint path_forall_ap_operation `{Funext} {σ : Signature}
  {A : Carriers σ} {w : SymbolType σ}
  : ∀ (f g : Operation A w),
    (∀ a : FamilyProd A (dom_symboltype w),
       ap_operation f a = ap_operation g a)
    -> f = g
  := match w with
     | [:s:] => λ (f g : A s) p, p tt
     | s ::: w' =>
         λ (f g : A s → Operation A w') p,
          path_forall f g
            (λ x, path_forall_ap_operation (f x) (g x) (λ a, p (x,a)))
     end.

(** An [Algebra σ] for a signature [σ] consists of a family [carriers :
    Carriers σ] indexed by the sorts [s : Sort σ], and for each symbol
    [u : Symbol σ], an operation of type [Operation carriers (σ u)],
    where [σ u : SymbolType σ] is the symbol type of [u]. *)

Record Algebra {σ : Signature} : Type := BuildAlgebra
  { carriers : Carriers σ
  ; operations : ∀ (u : Symbol σ), Operation carriers (σ u) }.

Arguments Algebra : clear implicits.

Arguments BuildAlgebra {σ} carriers operations.

(** We have a convenient implicit coercion from an algebra to the
    family of carriers. *)
Global Coercion carriers : Algebra >-> Funclass.

Definition SigAlgebra (σ : Signature) : Type
  := {c : Carriers σ | ∀ (u : Symbol σ), Operation c (σ u) }.

Lemma issig_algebra (σ : Signature) : SigAlgebra σ <~> Algebra σ.
Proof.
  unfold SigAlgebra.
  issig (@BuildAlgebra σ) (@carriers σ) (@operations σ).
Defined.

Class IsTruncAlgebra (n : trunc_index) {σ : Signature} (A : Algebra σ)
  := trunc_carriers_algebra : ∀ (s : Sort σ), IsTrunc n (A s).

Global Existing Instance trunc_carriers_algebra.

Notation IsHSetAlgebra := (IsTruncAlgebra 0).

Global Instance hprop_is_trunc_algebra `{Funext} (n : trunc_index)
  {σ : Signature} (A : Algebra σ)
  : IsHProp (IsTruncAlgebra n A).
Proof.
  apply trunc_forall.
Qed.

Global Instance trunc_algebra_succ {σ : Signature} (A : Algebra σ)
  {n} `{!IsTruncAlgebra n A}
  : IsTruncAlgebra n.+1 A | 1000.
Proof.
  intro; exact _.
Qed.

(** To find a path between two algebras [A B : Algebra σ] it suffices
    to find paths between the carriers and the operations. *)

Lemma path_algebra {σ : Signature} (A B : Algebra σ)
  (p : carriers A = carriers B)
  (q : transport (λ X, ∀ u, Operation X (σ u)) p (operations A)
       = operations B)
  : A = B.
Proof.
  destruct A,B. cbn in *. by path_induction.
Defined.

Lemma path_ap_carriers_path_algebra {σ} (A B : Algebra σ)
  (p : carriers A = carriers B)
  (q : transport (λ X, ∀ u, Operation X (σ u)) p (operations A)
       = operations B)
  : ap carriers (path_algebra A B p q) = p.
Proof.
  destruct A as [A a], B as [B b]. cbn in *. by destruct p,q.
Defined.

(** Suppose [p],[q] are paths in [Algebra σ]. To show that [p = q] it
    suffices to find a path [r] between the paths corresponding to
    [p] and [q] in [SigAlgebra σ]. *)

Lemma path_path_algebra {σ : Signature} {A B : Algebra σ} (p q : A = B)
  (r : ap (issig_algebra σ)^-1 p = ap (issig_algebra σ)^-1 q)
  : p = q.
Proof.
  set (e := (Paths.equiv_ap (issig_algebra σ)^-1 A B)).
  by apply (@equiv_inv _ _ (ap e) (Equivalences.isequiv_ap _ _)).
Defined.

(** If [p q : A = B] and [IsHSetAlgebra B].
    Then [ap carriers p = ap carriers q] implies [p = q]. *)

Lemma path_path_hset_algebra `{Funext} {σ : Signature}
  {A B : Algebra σ} `{IsHSetAlgebra B}
  (p q : A = B) (r : ap carriers p = ap carriers q)
  : p = q.
Proof.
  apply path_path_algebra.
  unshelve eapply path_path_sigma.
  - transitivity (ap carriers p); [by destruct p |].
    transitivity (ap carriers q); [exact r | by destruct q].
  - apply hprop_allpath. apply set_path2.
Defined.

Module algebra_notations.

(** Given [A : Algebra σ] and function symbol [u : Symbol σ], we use
    the notation [u ^^ A] to refer to the corresponding algebra
    operation of type [Operation A (σ u)]. *)

  Global Notation "u ^^ A" := (operations A u)
                              (at level 60, no associativity)
                              : Algebra_scope.

End algebra_notations.