(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import VST.msl.base.
Require Import VST.msl.ageable.
Require Import Coq.Logic.Eqdep_dec.
Require Import VST.msl.functors.

Import CovariantFunctor.
Import CovariantFunctorLemmas.
Import CovariantFunctorGenerator.

Local Open Scope nat_scope.

Module Type TY_FUNCTOR.
  Parameter F : functor.

  Parameter T : Type.
  Parameter T_bot : T.

  Parameter other : Type.
End TY_FUNCTOR.

Module Type KNOT.
  Declare Module TF:TY_FUNCTOR.
  Import TF.

  Parameter knot : Type.

  Parameter ag_knot : ageable knot.
  Existing Instance ag_knot.
  Existing Instance ag_prod.

  Definition predicate := (knot * other) -> T.

  Parameter squash : (nat * F predicate) -> knot.
  Parameter unsquash : knot -> (nat * F predicate).

  Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => if le_gt_dec n (level w) then T_bot else p w.

  Axiom squash_unsquash : forall x, squash (unsquash x) = x.
  Axiom unsquash_squash : forall n x', unsquash (squash (n,x')) = (n,fmap F (approx n) x').

  Axiom knot_level : forall k:knot,
    level k = fst (unsquash k).

  Axiom knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

End KNOT.

Module Knot (TF':TY_FUNCTOR) : KNOT with Module TF:=TF'.
  Module TF := TF'.
  Import TF.

  (* Put the discrete pointed order on rhs *)
  Inductive leT : T -> T -> Prop :=
   | leT_refl : forall t, leT t t
   | leT_bot: forall t, leT T_bot t.

  Lemma leT_asym: forall t t',
    leT t t' -> leT t' t -> t = t'.
  Proof.
    intros.
    inversion H; subst; auto.
    inversion H0; subst; auto.
  Qed.

  Fixpoint sinv (n: nat) : Type :=
    match n with
      | O => unit
      | S n => prodT (sinv n) ((F (sinv n) * other) -> T)
    end.

  Fixpoint floor (m:nat) (n:nat) (p:sinv (m+n)) : sinv n :=
    match m as m' return forall (p : sinv (m'+n)), sinv n with
    | O => fun p => p
    | S m' => fun p => floor m' n (fst p)
    end p.

  Definition knot := { n:nat & F (sinv n) }.

  Definition predicate := knot * other -> T.

  Fixpoint stratify (n:nat) (Q:predicate) {struct n} : sinv n :=
    match n as n' return sinv n' with
    | O => tt
    | S n' => ( stratify n' Q, fun v => Q (existT (F oo sinv) n' (fst v),snd v) )
    end.

  Lemma decompose_nat : forall (x y:nat), { m:nat & y = (m + S x) } + { ge x y }.
  Proof.
    intros x y; revert x; induction y; simpl; intros.
    right; auto with arith.
    destruct (IHy x) as [[m H]|H].
    left; exists (S m); omega.
    destruct (eq_nat_dec x y).
    left; exists O; omega.
    right; omega.
  Qed.

  Definition unstratify (n:nat) (p:sinv n) : predicate := fun w =>
    match w with (existT _ nw w',e) =>
      match decompose_nat nw n with
        | inleft (existT _ m Hm) => snd (floor m (S nw) (eq_rect  n _ p (m + S nw) Hm)) (w', e)
        | inright H => T_bot
      end
    end.

  Definition proof_irr_nat := eq_proofs_unicity dec_eq_nat.
  Arguments proof_irr_nat [x] [y] _ _.

  Lemma floor_shuffle:
    forall (m1 n : nat)
      (p1 : sinv (m1 + S n)) (H1 : (m1 + S n) = (S m1 + n)),
      floor (S m1) n (eq_rect (m1 + S n) sinv p1 (S m1 + n) H1) = fst (floor m1 (S n) p1).
  Proof.
    intros.
    remember (fst (floor m1 (S n) p1)) as p.
    revert n p1 H1 p Heqp.
    induction m1; simpl; intros.
    replace H1 with (refl_equal (S n)) by (apply proof_irr_nat); simpl; auto.
    assert (m1 + S n = S m1 + n) by omega.
    destruct p1 as [p1 f'].
    generalize (IHm1 n p1 H p Heqp).
    simpl.
    clear.
    revert H1; generalize H.
    revert p1 f'.
    rewrite H.
    simpl; intros.
    replace H1 with (refl_equal (S (S (m1 + n)))) by (apply proof_irr_nat).
    simpl.
    replace H0 with (refl_equal (S (m1+n))) in H2 by (apply proof_irr_nat).
    simpl in H2.
    trivial.
  Qed.

  Lemma stratify_unstratify_more : forall n m1 m2 p1 p2,
    floor m1 n p1 = floor m2 n p2 ->

    (stratify n oo unstratify (m1+n)) p1 =
    (stratify n oo unstratify (m2+n)) p2.
  Proof.
    unfold compose; induction n; simpl; intros; auto.
    apply injective_projections; simpl; trivial.

    assert ((m1 + S n) =  (S m1 + n)) by omega.
    assert ((m2 + S n) =  (S m2 + n)) by omega.
    assert (floor (S m1) n (eq_rect (m1 + S n) _ p1 _ H0) = floor (S m2) n (eq_rect (m2 + S n) _ p2 _ H1)).
    do 2 rewrite floor_shuffle.
    congruence.
    generalize (IHn (S m1) (S m2) _ _ H2).
    clear.
    generalize H0 H1.
    revert p1 p2.
    rewrite H0; clear H0.
    rewrite H1; clear H1.
    intros p1 p2 H1 H2.
    replace H1 with (refl_equal (S m1 + n)) by (apply proof_irr_nat).
    replace H2 with (refl_equal (S m2 + n)) by (apply proof_irr_nat).
    simpl; auto.

    apply extensionality; intro v.
    unfold unstratify.
    destruct (decompose_nat n (m2 + S n)) as [[r Hr]|Hr].
    2: elimtype False; omega.
    destruct (decompose_nat n (m1 + S n)) as [[s Hs]|Hs].
    2: elimtype False; omega.
    assert (m2 = r) by omega; subst r.
    assert (m1 = s) by omega; subst s.
    simpl.
    replace Hr with (refl_equal (m2 + S n)) by (apply proof_irr_nat).
    replace Hs with (refl_equal (m1 + S n)) by (apply proof_irr_nat).
    simpl.
    rewrite H; auto.
  Qed.

  Lemma stratify_unstratify : forall n,
         stratify n oo unstratify n = id (sinv n).
  Proof.
    unfold id, compose; intro n; extensionality p; revert n p.
    induction n.

    intros; destruct p; auto.

    simpl; intros [p f].
    apply injective_projections; simpl; trivial.

    replace (stratify n (unstratify (S n) (p,f))) with
            (stratify n (unstratify n p)); auto.
    replace (stratify n (unstratify n p)) with
      ((stratify n oo unstratify (0+n)) p) by trivial.
    rewrite (stratify_unstratify_more _ 0 1 p (p,f)); trivial.

    extensionality v.

    destruct (decompose_nat n (S n)) as [[r Hr]|?]; auto.
    assert (r = O) by omega; subst r.
    simpl in *.
    replace Hr with (refl_equal (S n)) by (apply proof_irr_nat); simpl; auto.
    destruct v; auto.

    elimtype False.
    omega.
  Qed.

  Lemma unstratify_stratify1 : forall n (p:predicate) w,
    leT ((unstratify n oo stratify n) p w) (p w).
  Proof.
    unfold compose; induction n; simpl; intros; unfold unstratify.

    (* 0 case *)
    destruct w as [nw rm]; simpl.
    destruct nw as [nw e].
    destruct (decompose_nat nw O) as [[r Hr]|?].
    elimtype False; omega.
    apply leT_bot.

    (* S n case *)
    case_eq w; intros nw rm Hrm.
    destruct nw as [nw e].
    destruct (decompose_nat nw (S n)) as [[r Hr]|?]; try (apply lt_rhs_top).
    destruct r; simpl.

    assert (n = nw) by omega.
    subst nw.
    simpl in Hr.
    replace Hr with (refl_equal (S n)) by apply proof_irr_nat; simpl.
    unfold compose.
    destruct w.
    apply leT_refl.

    simpl in Hr.
    assert (n = r + S nw) by omega.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S nw))) by apply proof_irr_nat; simpl.
    clear Hr.

    generalize (IHn p w).
    unfold unstratify.
    rewrite Hrm.
    destruct (decompose_nat nw (r + S nw)) as [[x Hx]|?].
    assert (x = r) by omega; subst x.
    replace Hx with (refl_equal (r + S nw)) by apply proof_irr_nat.
    simpl; auto.
    elimtype False; omega.
    apply leT_bot.
  Qed.

  Lemma unstratify_stratify2 : forall n p w,
     projT1 (fst w) < n ->
        leT (p w) ((unstratify n oo stratify n) p w).
  Proof.
    unfold compose.
    induction n; simpl; intros.

    (* 0 case *)
    inversion H.

    (* S n case *)
    unfold unstratify.
    case_eq w; intros [m rm] e Hw.
    assert (projT1 (fst w) = m).
    rewrite Hw; auto.

    destruct (decompose_nat m (S n)) as [[r Hr]|?].
    destruct r; simpl.

    assert (n = m) by omega.
    move H0 after H1.
    subst m. fold sinv. simpl in Hr. rewrite (proof_irr_nat Hr (refl_equal _)). clear Hr.
    simpl.
    unfold compose.
    rewrite <- Hw.
    apply leT_refl.

    simpl in Hr.
    assert (n = r + S m) by omega.
    revert Hr; subst n.
    intro Hr.
    replace Hr with (refl_equal (S (r+S m))) by apply proof_irr_nat; simpl.
    clear Hr.
    rewrite H0 in H.
    assert (m < (r +  S m)) by omega.
    specialize ( IHn p w).
    rewrite H0 in IHn.
    specialize ( IHn H1).
    revert IHn.
    unfold unstratify.
    rewrite Hw.
    destruct (decompose_nat m (r + S m)) as [[x Hx]|?].
    assert (x = r) by omega; subst x.
    replace Hx with (refl_equal (r + S m)) by apply proof_irr_nat.
    simpl; auto.
    elimtype False; omega.
    elimtype False; omega.
  Qed.

  Lemma unstratify_stratify3 : forall n (p:predicate) w,
    projT1 (fst w) >= n -> leT ((unstratify n oo stratify n) p w) T_bot.
  Proof.
    unfold compose, unstratify; intros n p w H.
    case_eq w; intros [wn rm] e.
    intro Hrm.
    rewrite Hrm in H; simpl in H.
    destruct (decompose_nat wn n) as [[r Hr]|?].
    elimtype False; omega.
    apply leT_bot.
  Qed.

  Definition squash (x:nat * F predicate) : knot :=
    match x with (n,y) => existT (F oo sinv) n (fmap F (stratify n) y) end.

  Definition unsquash (x:knot) : (nat * F predicate) :=
    match x with existT _ n y => (n, fmap F (unstratify n) y) end.

  Definition def_knot_level (k:knot) := fst (unsquash k).

  Definition def_knot_age1 (k:knot) : option knot :=
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.

  Definition def_knot_unage (k:knot) : knot :=
    match unsquash k with
    | (n,x) => squash (S n,x)
    end.

  Definition approx (n:nat) (p:predicate) : predicate :=
     fun w => if le_gt_dec n (def_knot_level (fst w)) then T_bot else p w.

  Lemma squash_unsquash : forall x, squash (unsquash x) = x.
  Proof.
    intros; destruct x as [x f]; simpl.
    unfold compose.
    replace (fmap F (stratify x) (fmap F (unstratify x) f)) with
      ((fmap F (stratify x) oo fmap F (unstratify x)) f) by trivial.
    rewrite fmap_comp.
    replace (stratify x oo unstratify x) with (id (sinv x)).
    rewrite fmap_id; simpl; auto.
    unfold compose.
    extensionality z.
    replace (stratify x (unstratify x z)) with ((stratify x oo unstratify x) z) by trivial.
    rewrite stratify_unstratify; auto.
  Qed.

  Lemma unsquash_squash : forall n x', unsquash (squash (n,x')) = (n,fmap F (approx n) x').
  Proof.
    intros.
    simpl.
    replace (fmap F  (unstratify n) (fmap F (stratify n) x')) with
      ((fmap F (unstratify n) oo fmap F (stratify n)) x') by trivial.
    rewrite fmap_comp.
    apply injective_projections; simpl; trivial.
    replace (unstratify n oo stratify n) with (approx n); auto.
    extensionality p z.
    apply leT_asym.

    intuition.
    case (le_gt_dec n (def_knot_level a)); intro.
    replace (approx n p (a, b)) with T_bot.
    apply leT_bot.
    unfold approx.
    simpl.
    case (le_gt_dec n (def_knot_level a)); intro.
    trivial.
    elimtype False.
    omega.
    replace (approx n p (a,b)) with (p (a,b)).
    apply unstratify_stratify2.
    simpl.
    destruct a.
    unfold level in g.
    simpl in *.
    auto.
    unfold approx.
    simpl.
    case (le_gt_dec n (def_knot_level a)); intro.
    elimtype False.
    omega.
    trivial.

    intuition.
    destruct (le_lt_dec n (def_knot_level a)).
    replace (approx n p (a, b)) with T_bot.
    apply unstratify_stratify3; auto.
    simpl.
    destruct a.
    unfold level in l.
    simpl in *.
    auto.
    unfold approx.
    simpl.
    case (le_gt_dec n (def_knot_level a)); auto.
    intro.
    elimtype False.
    omega.
    replace (approx n p (a, b)) with (p (a, b)).
    apply unstratify_stratify1; auto.
    unfold approx.
    simpl.
    case (le_gt_dec n (def_knot_level a)); auto.
    intro.
    elimtype False.
    omega.
  Qed.

  Lemma unsquash_inj : forall k1 k2,
    unsquash k1 = unsquash k2 ->
    k1 = k2.
  Proof.
    intros.
    rewrite <- (squash_unsquash k1).
    rewrite <- (squash_unsquash k2).
    rewrite H.
    trivial.
  Qed.
  Arguments unsquash_inj [k1 k2] _.

  Lemma ag_knot_facts : ageable_facts knot def_knot_level def_knot_age1.
  Proof.
    constructor.

   unfold def_knot_age1; unfold def_knot_level; simpl; intros x'.
    case_eq (unsquash x'); intros.
    destruct x' as [n' xx']. simpl in *. inv H.
    exists (squash (S n, fmap F (unstratify n) xx')).
    rewrite unsquash_squash.
    f_equal.
    f_equal.
    transitivity ((fmap F (stratify n) oo fmap F (approx (S n)) oo fmap F (unstratify n)) xx'); auto.
    do 2 rewrite fmap_comp.
    replace (stratify n oo approx (S n) oo unstratify n) with (@id (sinv n)).
    rewrite fmap_id. auto.
   clear.
    rewrite <- (stratify_unstratify n).
    f_equal. extensionality  a w.
    unfold approx, compose. destruct w.
    simpl fst.
    destruct (le_gt_dec (S n) (def_knot_level k)); auto.
    destruct k. simpl in *.
    unfold def_knot_level in l.
    simpl in *.
    destruct (decompose_nat x n); auto.
    destruct s. elimtype False.
    omega.

    intros.
    unfold def_knot_age1, def_knot_level.
    destruct (unsquash x); simpl.
    destruct n; intuition; try discriminate.

    unfold def_knot_age1, def_knot_level; intros.
    destruct (unsquash x).
    destruct n; inv H; simpl; auto.
  Qed.

  Definition ag_knot : ageable knot :=
    mkAgeable knot def_knot_level def_knot_age1 ag_knot_facts .
  Existing Instance ag_knot.
  Existing Instance ag_prod.

  Lemma knot_level : forall k:knot,
    level k = fst (unsquash k).
  Proof (fun k => refl_equal (def_knot_level k)).

  Lemma knot_age1 : forall k:knot,
    age1 k =
    match unsquash k with
    | (O,_) => None
    | (S n,x) => Some (squash (n,x))
    end.
  Proof (fun k => refl_equal (def_knot_age1 k)).

End Knot.


Require Import lib Omega util Subst List.

Section Subst.

Context {term : Type}.
Context {subst_funs : Subst term}.
Context {subst_lemmas : SubstLemmas _ subst_funs}.

Inductive get {term : Type} {term_subst : Subst term}
: list term -> var -> term -> Prop :=
| Get0 Delta A: get Delta,,A 0 A
| GetS Delta x A B : get Delta x B -> get Delta,,A (S x) B
.

Inductive dget {term : Type} {term_subst : Subst term}
: list term -> var -> term -> Prop :=
| DGet0 Delta A: dget Delta,,A 0 A.[ren(+1)]
| DGetS Delta x A B : dget Delta x B -> dget Delta,,A (S x) B.[ren(+1)]
.

Lemma lift_inj (A B : term) n : A.[ren(+n)] = B.[ren(+n)] -> A = B.
Proof.
  intros H.
  apply (f_equal (subst (ren (fun x => x - n)))) in H.
  ssimpl in H.
  cutrewrite ( ren ((+n) >>> ((fun x : var => x - n) : var -> var)) = Var) in H.
  now ssimpl in H.
  unfold lift.
  f_ext. intros x. simpl. f_equal. omega.
Qed.

Lemma dget_steps x Gamma Delta A : dget Gamma x A <-> dget (Gamma,,,Delta) (length Delta + x) A.[ren(+(length Delta))].
Proof.
  revert A x.
  induction Delta; intros.
  - split.
    + now ssimpl.
    + now ssimpl.
  - simpl. cutrewrite (A.[ren (+S (length Delta))] = A.[ren(+length Delta)].[ren(+1)]); [idtac | now ssimpl].
    split.
      + constructor. now apply IHDelta.
      + intros H. inv H. rewrite IHDelta. apply lift_inj in H4. rewrite H4 in H1. eassumption.
Qed.

Lemma dget_steps' x Gamma Delta A :  dget (Gamma,,,Delta) (x + length Delta) A ->
                               exists B, A = B.[ren(+(length Delta))] /\ dget Gamma x B.
Proof.
  revert A x.
  induction Delta; intros.
  - exists A.
    simpl in H.
    rewrite plus_0_r in H. ssimpl.
    intuition.
  - ssimpl. simpl in *.
    rewrite NPeano.Nat.add_succ_r in *.
    inv H.
    edestruct IHDelta as [B' [? ?]]; eauto. exists B'. subst.
    ssimpl. intuition.
Qed.

Corollary dget_step Delta A x B : dget Delta x A <-> dget (Delta,,B) (S x) A.[ren(+1)].
Proof.
  apply dget_steps with (Delta := B :: nil).
Qed.

Lemma dget_repl Gamma A Delta :
  (dget Gamma,,A,,,Delta (length Delta) A.[ren(+ S (length Delta))]) /\
  (forall x B A', x <> length Delta -> dget Gamma,,A,,,Delta x B -> dget Gamma,,A',,,Delta x B).
Proof.
  split.
  - pose proof (dget_steps 0 Gamma,,A Delta A.[ren(+1)]) as H.
    rewrite plus_0_r in H.
    cutrewrite (A.[ren (+1)].[ren (+length Delta)] =  A.[ren (+S (length Delta))]) in H. { apply H. constructor. }
    now ssimpl.
  - intros x. revert Gamma A Delta.
    induction x; intros Gamma A Delta H B A' H_get.
    + destruct Delta as [| C Delta]. { now intuition. }
      simpl in *.
      inv H_get. constructor.
    + destruct Delta as [| C Delta]; simpl in *.
      * inv H_get. now constructor.
      * inv H_get. constructor. eapply IHx; eauto.
Qed.

Lemma dget_defined Delta x : (exists B, dget Delta x B) <-> x < length Delta.
Proof.
  revert Delta.
  induction x; intros; split.
  - intros [? H]. inversion H. simpl. omega.
  - intro H. destruct Delta; first by inversion H. eexists. constructor.
  - intros [? H]. inversion H. simpl.
    assert(x < length Delta0).
    { apply IHx. eexists. eassumption. }
    omega.
  - intro H. destruct Delta; first by inversion H.
    destruct (IHx Delta) as [_ IHx'].
    edestruct IHx'; first by simpl in H; omega.
    eexists. constructor. eassumption.
Qed.

End Subst.


Require Export UnivalenceImpliesFunext.
Require Export BS deloop combinatorics_tmp.

Section deloop_to_BS.
Let deloop := deloop.deloop.

Open Scope type.

Context `{Univalence}.

(** We define a family of functions deloop n -> BS n **)

  Definition dtb_dlpt0b
    : Type
    := Fin 0.

  Definition dtb_dlpt0f
    : Trunc (-1) (dtb_dlpt0b <~> Fin 0)
    := (tr 1%equiv).

  Definition dtb_dlib
    : nat -> Type -> Type
    := fun _ => add.

  Definition dtb_dlif
    : forall (n : nat) (A : Type), merely (A <~> Fin n) -> merely (dtb_dlib n A <~> Fin n.+1).
  Proof.
    simpl; intros n A; unfold dtb_dlib, add.
    srapply @Trunc_rec; intro e.
    exact (tr (exp e)).
  Qed.

  Definition dtb_dltwb
    : forall (n : nat) (A : Type), dtb_dlib n.+1 (dtb_dlib n A) = dtb_dlib n.+1 (dtb_dlib n A).
  Proof.
    intros; unfold dtb_dlib, add.
    exact (gamma A).
  Defined.

  Definition dtb_dldob
    : forall (n : nat) (A : Type), dtb_dltwb n A @ dtb_dltwb n A = idpath.
  Proof.
    intros; unfold dtb_dltwb.
    apply gamma_double.
  Defined.

  Definition dtb_dlbrb
    : forall (n : nat) (A : Type),
      (dtb_dltwb n.+1 (dtb_dlib n A) @ ap (dtb_dlib n.+2) (dtb_dltwb n A)) @ dtb_dltwb n.+1 (dtb_dlib n A) =
      (ap (dtb_dlib n.+2) (dtb_dltwb n A) @ dtb_dltwb n.+1 (dtb_dlib n A)) @ ap (dtb_dlib n.+2) (dtb_dltwb n A).
  Proof.
    intros; unfold dtb_dlib, dtb_dltwb.
    apply gamma_triple.
  Defined.

Definition deloop_to_BS
  : forall n : nat, deloop n -> BS n
  := deloop_rec_subuniverse (fun n A => merely (A <~> Fin n)) BS_trunc _ dtb_dlpt0b dtb_dlpt0f dtb_dlib dtb_dlif dtb_dltwb dtb_dldob dtb_dlbrb.

Definition deloop_to_BSb
  : forall n : nat, deloop n -> Type
  := fun n a => (deloop_to_BS n a).1.

(** judgmentally, we have that
   deloop_to_BSb 0 dlpt0        computes to   Empty, and
   deloop_to_BSb n.+1 (dli a)   computes to   deloop_to_BSb n a + Unit, for every n : nat, a : deloop n.
The other 'computation' rule comes below: **)

Definition ap_deloop_to_BSb_dltw {n} (a : deloop n)
  : ap (deloop_to_BSb n.+2) (dltw a) = gamma (deloop_to_BSb n a).
Proof.
  unfold deloop_to_BSb.
  refine (ap_compose (deloop_to_BS n.+2) pr1 (dltw a) @ _).
  exact (deloop_rec_truncfib_beta_dltw Type (fun n A => merely (A <~> Fin n)) BS_trunc _ dtb_dlpt0b dtb_dlpt0f dtb_dlib dtb_dlif dtb_dltwb dtb_dldob dtb_dlbrb n a).
Defined.

Definition ap_deloop_to_BSb_ap_dli
  {n} {a b : deloop n} (p : a = b)
  : ap (deloop_to_BSb n.+1) (ap dli p) = ap add (ap (deloop_to_BSb n) p).
Proof.
  induction p; constructor.
Defined.

(** We define our preferred finite types **)
Definition FFin (n : nat)
  : Type
  := deloop_to_BSb n (dlpt n).

Lemma FFin_Fin
  : forall n : nat, FFin n = Fin n.
Proof.
  induction n.
  + constructor.
  + exact (ap add IHn).
Defined.

(** Some results we can achieve via deloop_to_BS **)

Lemma not_dltw_idpath {n : nat} (a : deloop n)
  : dltw a = idpath -> Empty.
Proof.
  intro p.
  apply (@not_omega_id (deloop_to_BSb n a)).
  refine ((eisretr (equiv_path _ _) _)^ @ _ @ eisretr (equiv_path _ _) _); apply ap.
  change (gamma (deloop_to_BSb n a) = path_universe_uncurried 1%equiv).
  refine (_ @ path_universe_1^).
  refine ((ap_deloop_to_BSb_dltw a)^ @ _).
  exact (ap (ap (deloop_to_BSb n.+2)) p).
Defined.

Lemma not_deloop_set_from_2 (n : nat)
  : (forall (a b : deloop n.+2) (p q : a = b), p = q) -> Empty.
Proof.
  intro abs.
  exact (not_dltw_idpath (dlpt n) (abs (dlpt n.+2) (dlpt n.+2) (dltw (dlpt n)) idpath)).
Defined.

(** Definition of the function deloop_dot -> BS_dot **)

Definition deloop_to_BS_dot
  : deloop_dot -> BS_dot
  := sigma_function idmap deloop_to_BS.

Definition deloop_to_BSb_dot
  : deloop_dot -> Type
  := fun x => (deloop_to_BS_dot x).2.1.

Definition deloop_to_BS_dot'
  : deloop_dot -> BS_dot'
  := BS_dot_dot' o deloop_to_BS_dot.

Definition Saddb
  : nat * Type -> nat * Type
  := fun x => match x with (n, A) => (S n, add A) end.

Definition Sadd
  : BS_dot' -> BS_dot'
  := @sigma_function (nat * Type) (fun z => merely (snd z <~> Fin (fst z))) (nat * Type) (fun z => merely (snd z <~> Fin (fst z))) Saddb (fun z => dtb_dlif (fst z) (snd z)).

Lemma deloop_to_BS_dot'_Sdli
  : forall x : deloop_dot, deloop_to_BS_dot' (Sdli x) = Sadd (deloop_to_BS_dot' x).
Proof.
  constructor.
Defined.

(** Sketch of the proof that it is a symmetric monoidal functor **)
Open Scope nat.

Definition deloop_to_BS_dot'_0
  : BS_dot'_e = deloop_to_BS_dot' (dlpt0_dot)
  := idpath.

  Definition deloop_to_BS_dot'_2_dlpt0 (m : nat) (b : deloop m)
    : BS_dot'_product (deloop_to_BS_dot' (0; dlpt0)) (deloop_to_BS_dot' (m; b)) = deloop_to_BS_dot' (deloop_m (0; dlpt0) (m; b)).
  Proof.
    intros.
    srefine (sigma_truncfib _ _ _); simpl.
    exact (path_prod' idpath (lambda_U _)).
  Defined.

  Definition deloop_to_BS_dot'_2_dli (m : nat) (b : deloop m)
    : forall (n : nat) (a : deloop.deloop n),
    BS_dot'_product (deloop_to_BS_dot' (n; a)) (deloop_to_BS_dot' (m; b)) = deloop_to_BS_dot' (deloop_m (n; a) (m; b)) ->
    BS_dot'_product (deloop_to_BS_dot' (n.+1; dli a)) (deloop_to_BS_dot' (m; b)) = deloop_to_BS_dot' (deloop_m (n.+1; dli a) (m; b)).
  Proof.
    intros n a h.
    srefine (sigma_truncfib _ _ _).
    change (((n + m).+1, (deloop_to_BSb n a + Unit + deloop_to_BSb m b)%type) = ((deloop_to_BS_dot (deloop_m (n; a) (m; b))).1.+1,
deloop_to_BSb_dot (Sdli (deloop_m (n; a) (m; b))))).
    refine (path_prod' idpath (alpha_U _ _ _ @ (ap011 (fun X Y => (X + Y)%type) idpath (tau_U _ _)) @ (alpha_U _ _ _)^) @ _).
    change (Saddb (n + m, (deloop_to_BSb n a + deloop_to_BSb m b)%type) = (((deloop_to_BS_dot (deloop_m (n; a) (m; b))).1).+1, deloop_to_BSb_dot (Sdli (deloop_m (n; a) (m; b))))).
    exact (ap Saddb h..1).
  Defined.

  Definition deloop_to_BS_dot'_2_dltw (m : nat) (b : deloop m)
    : forall (n : nat) (a : deloop n) (a' : BS_dot'_product (deloop_to_BS_dot' (n; a)) (deloop_to_BS_dot' (m; b)) =
      deloop_to_BS_dot' (deloop_m (n; a) (m; b))),
      transport
        (fun a0 : deloop n.+2 => BS_dot'_product (deloop_to_BS_dot' (n.+2; a0)) (deloop_to_BS_dot' (m; b)) = deloop_to_BS_dot' (deloop_m (n.+2; a0) (m; b)))
        (dltw a)
        (deloop_to_BS_dot'_2_dli m b n.+1 (dli a) (deloop_to_BS_dot'_2_dli m b n a a'))
      = deloop_to_BS_dot'_2_dli m b n.+1 (dli a) (deloop_to_BS_dot'_2_dli m b n a a').
  Proof.
    intros n a h; hnf.
    refine (@transport_paths_FlFr (deloop n.+2) _ (fun a0 => BS_dot'_product (deloop_to_BS_dot' (n.+2; a0)) (deloop_to_BS_dot' (m; b))) (fun a0 => deloop_to_BS_dot' (deloop_m (n.+2; a0) (m; b))) _ _ (dltw a) _ @ concat_pp_p _ _ _ @ _); apply moveR_Vp.
    (* ignore second component; split for nat and Type;
        for nat this is trivial, as nat is a set;
        for Type (see thesis) we can look at the equivalences instead of the paths, and verify that the underlying functions are homotopic *)
  Admitted.

Definition deloop_to_BS_dot'_2
  : forall x y : deloop_dot,
    BS_dot'_product (deloop_to_BS_dot' x) (deloop_to_BS_dot' y) = deloop_to_BS_dot' (deloop_m x y).
Proof.
  intros [n a] [m b]; revert a; revert n.
  assert (T : forall (n : nat) (a : deloop n), IsHSet (BS_dot'_product (deloop_to_BS_dot' (n; a)) (deloop_to_BS_dot' (m; b)) = deloop_to_BS_dot' (deloop_m (n; a) (m; b)))).
  { intros. srapply @istrunc_paths. exact BS_dot'_trunc. }
  srefine (deloop_ind_to_set _ _ _ _ T); clear T; hnf.
  + exact (deloop_to_BS_dot'_2_dlpt0 m b).
  + exact (deloop_to_BS_dot'_2_dli m b).
  + exact (deloop_to_BS_dot'_2_dltw m b).
Defined.

(* the _alp, _lam, _rho and _tau components only involve deloop_to_BS_dot'_2_dlpt0 and deloop_to_BS_dot'_2_dli;
   again one can look at the 2-paths in the base (nat * Type) and solve in nat by its 0-truncation and in Type by looking at the corresponding functions *)

End deloop_to_BS.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^196 - 15
Base: 21 + 7/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 21 + 7/9;
    bitwidth := 32;
    s := 2^196;
    c := [(1, 15)];
    carry_chains := Some [seq 0 (pred 9); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


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 A B U V W Q Z : Universe, ((wd_ U V /\ (wd_ A B /\ (wd_ U W /\ (wd_ V W /\ (wd_ A W /\ (wd_ W Q /\ (wd_ A Q /\ (col_ U V A /\ (col_ U V W /\ (col_ A Z Q /\ (col_ W A Q /\ col_ A A B))))))))))) -> col_ U V Z)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^222 - 117
Base: 44.4
***)

Definition curve : CurveParameters :=
  {|
    sz := 5%nat;
    base := 44 + 2/5;
    bitwidth := 64;
    s := 2^222;
    c := [(1, 117)];
    carry_chains := Some [seq 0 (pred 5); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export Bool.
Require Export LegacyRing_theory.
Require Export Quote.
Require Export Ring_normalize.
Require Export Ring_abstract.
Declare ML Module "ring_plugin".

(* As an example, we provide an instantation for bool. *)
(* Other instatiations are given in ArithRing and ZArithRing in the
   same directory *)

Definition BoolTheory :
  Ring_Theory xorb andb true false (fun b:bool => b) eqb.
split; simpl in |- *.
destruct n; destruct m; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct n; destruct m; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct n; reflexivity.
destruct n; reflexivity.
destruct n; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct x; destruct y; reflexivity || simpl in |- *; tauto.
Defined.

Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
 [ true false ].


(*****************************************************************************

 Display map bicategories

 Contents
 1. Subbicategories of the arrow bicategory
 2. Examples of subbicategories of the arrow bicategory
 3. Display map bicategories
 4. Examples of display map bicategories
 5. Closure conditions for display map bicategories
 6. Examples
 6.1 Bifinal
 6.2 Biinitial
 6.3 Composition
 6.4 Product morphism

 *****************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms.
Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.
Require Import UniMath.Bicategories.Morphisms.Properties.ContainsAdjEquiv.
Require Import UniMath.Bicategories.Morphisms.Properties.Composition.
Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderPullback.
Require Import UniMath.Bicategories.Morphisms.Properties.FromInitial.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Limits.Pullbacks.

Local Open Scope cat.

(**
 1. Subbicategories of the arrow bicategory
 *)
Section Subbicat.
  Context {B : bicat}
          (pred_mor : ∏ (e₁ e₂ b₁ b₂ : B)
                        (p₁ : e₁ --> b₁)
                        (p₂ : e₂ --> b₂)
                        (fe : e₁ --> e₂),
                      UU).

  Let P₁ {e₁ e₂ b₁ b₂ : B}
         (p₁ : e₁ --> b₁)
         (p₂ : e₂ --> b₂)
         (fe : e₁ --> e₂)
    : UU
    := pred_mor _ _ _ _ p₁ p₂ fe.

  Definition contains_id
    : UU
    := ∏ (e b : B)
         (p : e --> b),
       P₁ p p (id₁ _).

  Definition closed_under_comp
    : UU
    := ∏ (e₁ e₂ e₃ b₁ b₂ b₃ : B)
         (p₁ : e₁ --> b₁)
         (p₂ : e₂ --> b₂)
         (p₃ : e₃ --> b₃)
         (fe : e₁ --> e₂) (ge : e₂ --> e₃),
       P₁ p₁ p₂ fe
       →
       P₁ p₂ p₃ ge
       →
       P₁ p₁ p₃ (fe · ge).

  Definition contains_equiv_over_id
    : UU
    := ∏ (e₁ e₂ b : B)
         (p₁ : e₁ --> b)
         (p₂ : e₂ --> b)
         (fe : e₁ --> e₂),
       left_adjoint_equivalence fe
       →
       invertible_2cell p₁ (fe · p₂)
       →
       P₁ p₁ p₂ fe.

  Definition closed_under_invertible_2cell
    : UU
    := ∏ (e₁ e₂ b₁ b₂ : B)
         (p₁ p₁' : e₁ --> b₁)
         (p₂ p₂' : e₂ --> b₂)
         (fe fe'  : e₁ --> e₂)
         (α : invertible_2cell p₁ p₁')
         (β : invertible_2cell p₂ p₂')
         (γ : invertible_2cell fe fe')
         (H : P₁ p₁ p₂ fe),
       P₁ p₁' p₂' fe'.
End Subbicat.

Definition arrow_subbicat
           (B : bicat)
  : UU
  := ∑ (P₀ : ∏ (x y : B), x --> y → UU)
       (P₁ : ∏ (e₁ e₂ b₁ b₂ : B)
               (p₁ : e₁ --> b₁)
               (p₂ : e₂ --> b₂)
               (fe : e₁ --> e₂),
             UU),
     contains_id P₁
     ×
     closed_under_comp P₁
     ×
     closed_under_invertible_2cell P₁.

Section Projections.
  Context {B : bicat}
          (D : arrow_subbicat B).

  Definition pred_ob
             {x y : B}
             (f : x --> y)
    : UU
    := pr1 D x y f.

  Definition pred_mor
             {e₁ e₂ b₁ b₂ : B}
             (p₁ : e₁ --> b₁)
             (p₂ : e₂ --> b₂)
             (fe : e₁ --> e₂)
    : UU
    := pr12 D e₁ e₂ b₁ b₂ p₁ p₂ fe.

  Definition id_pred_mor
             {e b : B}
             (p : e --> b)
    : pred_mor p p (id₁ e)
    := pr122 D e b p.

  Definition comp_pred_mor
             {e₁ e₂ e₃ b₁ b₂ b₃ : B}
             {p₁ : e₁ --> b₁}
             {p₂ : e₂ --> b₂}
             {p₃ : e₃ --> b₃}
             {fe : e₁ --> e₂}
             {ge : e₂ --> e₃}
             (Hfe : pred_mor p₁ p₂ fe)
             (Hge : pred_mor p₂ p₃ ge)
    : pred_mor p₁ p₃ (fe · ge)
    := pr1 (pr222 D) _ _ _ _ _ _ _ _ _ _ _ Hfe Hge.

  Definition invertible_pred_mor
             {e₁ e₂ b₁ b₂ : B}
             {p₁ p₁' : e₁ --> b₁}
             {p₂ p₂' : e₂ --> b₂}
             {fe fe' : e₁ --> e₂}
             (α : invertible_2cell p₁ p₁')
             (β : invertible_2cell p₂ p₂')
             (γ : invertible_2cell fe fe')
             (H : pred_mor p₁ p₂ fe)
    : pred_mor p₁' p₂' fe'
    := pr2 (pr222 D) _ _ _ _ _ _ _ _ _ _ α β γ H.

  Definition invertible_pred_mor_1
             {e₁ e₂ b₁ b₂ : B}
             {p₁ p₁' : e₁ --> b₁}
             {p₂ : e₂ --> b₂}
             {fe : e₁ --> e₂}
             (α : invertible_2cell p₁ p₁')
             (H : pred_mor p₁ p₂ fe)
    : pred_mor p₁' p₂ fe
    := invertible_pred_mor α (id2_invertible_2cell _) (id2_invertible_2cell _) H.

  Definition invertible_pred_mor_2
             {e₁ e₂ b₁ b₂ : B}
             {p₁ : e₁ --> b₁}
             {p₂ p₂' : e₂ --> b₂}
             {fe : e₁ --> e₂}
             (β : invertible_2cell p₂ p₂')
             (H : pred_mor p₁ p₂ fe)
    : pred_mor p₁ p₂' fe
    := invertible_pred_mor (id2_invertible_2cell _) β (id2_invertible_2cell _) H.

  Definition invertible_pred_mor_3
             {e₁ e₂ b₁ b₂ : B}
             {p₁ : e₁ --> b₁}
             {p₂ : e₂ --> b₂}
             {fe fe' : e₁ --> e₂}
             (γ : invertible_2cell fe fe')
             (H : pred_mor p₁ p₂ fe)
    : pred_mor p₁ p₂ fe'
    := invertible_pred_mor (id2_invertible_2cell _) (id2_invertible_2cell _) γ H.
End Projections.

Definition make_arrow_subbicat
           {B : bicat}
           (P₀ : ∏ (x y : B), x --> y → UU)
           (P₁ : ∏ (e₁ e₂ b₁ b₂ : B)
                   (p₁ : e₁ --> b₁)
                   (p₂ : e₂ --> b₂)
                   (fe : e₁ --> e₂),
                 UU)
           (Hid : contains_id P₁)
           (Hcomp : closed_under_comp P₁)
           (Hinv : closed_under_invertible_2cell P₁)
  : arrow_subbicat B
  := (P₀ ,, P₁ ,, Hid ,, Hcomp ,, Hinv).

Definition arrow_subbicat_contains_equiv_over_id
           {B : bicat}
           (HB : is_univalent_2 B)
           (D : arrow_subbicat B)
  : contains_equiv_over_id (λ e₁ e₂ b₁ b₂ p₁ p₂ fe, pred_mor D p₁ p₂ fe).
Proof.
  intros e₁ e₂ b p₁ p₂ fe Hfe γ.
  refine (J_2_0
            (pr1 HB)
            (λ (x₁ x₂ : B) (L : adjoint_equivalence x₁ x₂),
             ∏ (p₁ : x₁ --> b)
               (p₂ : x₂ --> b)
               (γ : invertible_2cell p₁ (pr1 L · p₂)),
             pred_mor D p₁ p₂ (pr1 L))
            _
            (fe ,, Hfe)
            p₁
            p₂
            γ).
  cbn.
  clear e₁ e₂ p₁ p₂ fe Hfe γ.
  intros e p₁ p₂ γ.
  pose (c := comp_of_invertible_2cell γ (lunitor_invertible_2cell _)).
  use (J_2_1
         (pr2 HB)
         (λ (x₁ x₂ : B)
            (f g : x₁ --> x₂)
            (γ : invertible_2cell f g),
          pred_mor D f g (id₁ _))
         _
         c).
  cbn ; intros.
  apply (id_pred_mor D).
Defined.

Definition arrow_subbicat_props
           {B : bicat}
           (D : arrow_subbicat B)
  : UU
  := (∏ (x y : B) (f : x --> y), isaprop (pred_ob D f))
     ×
     (∏ (e₁ e₂ b₁ b₂ : B)
        (p₁ : e₁ --> b₁)
        (p₂ : e₂ --> b₂)
        (fe : e₁ --> e₂),
      isaprop (pred_mor D p₁ p₂ fe)).

(**
 2. Examples of subbicategories of the arrow bicategory
 *)
Definition full_arrow_subbicat
           {B : bicat}
           (P₀ : ∏ (x y : B), x --> y → UU)
  : arrow_subbicat B.
Proof.
  use make_arrow_subbicat.
  - exact P₀.
  - exact (λ _ _ _ _ _ _ _, unit).
  - exact (λ _ _ _, tt).
  - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _, tt).
  - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ _, tt).
Defined.

Definition full_arrow_subbicat_props
           {B : bicat}
           (P₀ : ∏ (x y : B), x --> y → UU)
           (isaprop_P₀ : ∏ (x y : B) (f : x --> y), isaprop (P₀ _ _ f))
  : arrow_subbicat_props (full_arrow_subbicat P₀).
Proof.
  split.
  - intros.
    apply isaprop_P₀.
  - intros.
    apply isapropunit.
Defined.

Definition intersection_arrow_subbicat
           {B : bicat}
           (D₁ D₂ : arrow_subbicat B)
  : arrow_subbicat B.
Proof.
  use make_arrow_subbicat.
  - exact (λ x y f, pred_ob D₁ f × pred_ob D₂ f).
  - exact (λ _ _ _ _ p₁ p₂ fe,
           pred_mor D₁ p₁ p₂ fe
           ×
           pred_mor D₂ p₁ p₂ fe).
  - intro ; intros.
    split ; apply id_pred_mor.
  - intros ? ? ? ? ? ? ? ? ? ? ? H₁ H₂.
    split.
    + exact (comp_pred_mor
               D₁
               (pr1 H₁) (pr1 H₂)).
    + exact (comp_pred_mor
               D₂
               (pr2 H₁) (pr2 H₂)).
  - intros e₁ e₂ b₁ b₂ p₁ p₁' p₂ p₂' fe fe' α β γ H.
    split.
    + exact (invertible_pred_mor D₁ α β γ (pr1 H)).
    + exact (invertible_pred_mor D₂ α β γ (pr2 H)).
Defined.

Definition intersection_arrow_subbicat_props
           {B : bicat}
           {D₁ D₂ : arrow_subbicat B}
           (HD₁ : arrow_subbicat_props D₁)
           (HD₂ : arrow_subbicat_props D₂)
  : arrow_subbicat_props (intersection_arrow_subbicat D₁ D₂).
Proof.
  split.
  - intros x y f.
    apply isapropdirprod.
    + exact (pr1 HD₁ _ _ f).
    + exact (pr1 HD₂ _ _ f).
  - intros e₁ e₂ b₁ b₂ p₁ p₂ fe.
    apply isapropdirprod.
    + exact (pr2 HD₁ _ _ _ _ p₁ p₂ fe).
    + exact (pr2 HD₂ _ _ _ _ p₁ p₂ fe).
Defined.

Definition faithful_subbicat
           (B : bicat)
  : arrow_subbicat B
  := full_arrow_subbicat (λ _ _ f, faithful_1cell f).

Definition faithful_subbicat_props
           (B : bicat)
  : arrow_subbicat_props (faithful_subbicat B).
Proof.
  use full_arrow_subbicat_props.
  intros.
  apply isaprop_faithful_1cell.
Defined.

Definition fully_faithful_subbicat
           (B : bicat)
  : arrow_subbicat B
  := full_arrow_subbicat (λ _ _ f, fully_faithful_1cell f).

Definition fully_faithful_subbicat_props
           (B : bicat)
  : arrow_subbicat_props (fully_faithful_subbicat B).
Proof.
  use full_arrow_subbicat_props.
  intros.
  apply isaprop_fully_faithful_1cell.
Defined.

Definition pseudomonic_subbicat
           (B : bicat)
  : arrow_subbicat B
  := full_arrow_subbicat (λ _ _ f, pseudomonic_1cell f).

Definition pseudomonic_subbicat_props
           (B : bicat)
  : arrow_subbicat_props (pseudomonic_subbicat B).
Proof.
  use full_arrow_subbicat_props.
  intros.
  apply isaprop_pseudomonic_1cell.
Defined.

Definition conservative_subbicat
           (B : bicat)
  : arrow_subbicat B
  := full_arrow_subbicat (λ _ _ f, conservative_1cell f).

Definition conservative_subbicat_props
           (B : bicat)
  : arrow_subbicat_props (conservative_subbicat B).
Proof.
  use full_arrow_subbicat_props.
  intros.
  apply isaprop_conservative_1cell.
Defined.

Definition discrete_subbicat
           (B : bicat)
  : arrow_subbicat B
  := full_arrow_subbicat (λ _ _ f, discrete_1cell f).

Definition discrete_subbicat_props
           (B : bicat)
  : arrow_subbicat_props (discrete_subbicat B).
Proof.
  use full_arrow_subbicat_props.
  intros.
  apply isaprop_discrete_1cell.
Defined.

Definition sfib_subbicat
           (B : bicat)
  : arrow_subbicat B.
Proof.
  use make_arrow_subbicat.
  - exact (λ _ _ f, internal_sfib f).
  - exact (λ _ _ _ _ p₁ p₂ fe, mor_preserves_cartesian p₁ p₂ fe).
  - intro ; intros.
    apply id_mor_preserves_cartesian.
  - intros e₁ e₂ e₃ b₁ b₂ b₃ p₁ p₂ p₃ fe ge Hf Hg.
    exact (comp_preserves_cartesian Hf Hg).
  - intros e₁ e₂ b₁ b₂ p₁ p₁' p₂ p₂' fe fe' α β γ H.
    exact (invertible_2cell_between_preserves_cartesian α β γ H).
Defined.

Definition sfib_subbicat_props
           (B : bicat)
           (HB_2_1 : is_univalent_2_1 B)
  : arrow_subbicat_props (sfib_subbicat B).
Proof.
  split.
  - intros ; simpl.
    apply isaprop_internal_sfib.
    exact HB_2_1.
  - intros ; simpl.
    apply isaprop_mor_preserves_cartesian.
Defined.

Definition sopfib_subbicat
           (B : bicat)
  : arrow_subbicat B.
Proof.
  use make_arrow_subbicat.
  - exact (λ _ _ f, internal_sopfib f).
  - exact (λ _ _ _ _ p₁ p₂ fe, mor_preserves_opcartesian p₁ p₂ fe).
  - intro ; intros.
    apply id_mor_preserves_opcartesian.
  - intros e₁ e₂ e₃ b₁ b₂ b₃ p₁ p₂ p₃ fe ge Hf Hg.
    exact (comp_preserves_opcartesian Hf Hg).
  - intros e₁ e₂ b₁ b₂ p₁ p₁' p₂ p₂' fe fe' α β γ H.
    exact (invertible_2cell_between_preserves_opcartesian α β γ H).
Defined.

Definition sopfib_subbicat_props
           (B : bicat)
           (HB_2_1 : is_univalent_2_1 B)
  : arrow_subbicat_props (sopfib_subbicat B).
Proof.
  split.
  - intros ; simpl.
    apply isaprop_internal_sopfib.
    exact HB_2_1.
  - intros ; simpl.
    apply isaprop_mor_preserves_opcartesian.
Defined.

Definition discrete_sfib_subbicat
           (B : bicat)
  : arrow_subbicat B
  := intersection_arrow_subbicat
       (sfib_subbicat B)
       (discrete_subbicat B).

Definition discrete_sfib_subbicat_props
           (B : bicat)
           (HB_2_1 : is_univalent_2_1 B)
  : arrow_subbicat_props (discrete_sfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_props.
  - exact (sfib_subbicat_props _ HB_2_1).
  - exact (discrete_subbicat_props B).
Defined.

Definition discrete_sopfib_subbicat
           (B : bicat)
  : arrow_subbicat B
  := intersection_arrow_subbicat
       (sopfib_subbicat B)
       (discrete_subbicat B).

Definition discrete_sopfib_subbicat_props
           (B : bicat)
           (HB_2_1 : is_univalent_2_1 B)
  : arrow_subbicat_props (discrete_sopfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_props.
  - exact (sopfib_subbicat_props _ HB_2_1).
  - exact (discrete_subbicat_props B).
Defined.

(**
 3. Display map bicategories
 *)
Section DispMapBicat.
  Context {B : bicat}
          (D : arrow_subbicat B).

  Definition closed_under_pb
    : UU
    := ∏ (pb x y z : B)
         (f : x --> z)
         (g : y --> z)
         (p₁ : pb --> x)
         (p₂ : pb --> y)
         (γ : invertible_2cell (p₁ · f) (p₂ · g)),
       pred_ob D f
       → has_pb_ump (make_pb_cone pb p₁ p₂ γ)
       → pred_ob D p₂ × pred_mor D p₂ f p₁.

  Definition contains_pb
    : UU
    := ∏ (x y z : B)
         (f : x --> z)
         (g : y --> z),
       pred_ob D f
       →
       ∑ (pb : B)
         (p₁ : pb --> x)
         (p₂ : pb --> y)
         (γ : invertible_2cell (p₁ · f) (p₂ · g)),
       has_pb_ump (make_pb_cone pb p₁ p₂ γ).

  Definition closed_under_pb_ump_mor
    : UU
    := ∏ (pb x y z : B)
         (f : x --> z)
         (g : y --> z)
         (p₁ : pb --> x)
         (p₂ : pb --> y)
         (γ : invertible_2cell (p₁ · f) (p₂ · g))
         (H : has_pb_ump (make_pb_cone pb p₁ p₂ γ))
         (cc c : B)
         (cp₁ : cc --> x)
         (cp₂ : cc --> c)
         (h : c --> y)
         (δ : invertible_2cell (cp₁ · f) ((cp₂ · h) · g))
         (cone := make_pb_cone cc cp₁ (cp₂ · h) δ),
       pred_ob D f
       → pred_mor D p₂ f p₁
       → pred_mor D cp₂ f cp₁
       → pred_mor D cp₂ p₂ (pb_ump_mor H cone).

  Definition contained_in_sfib
    : UU
    := ∏ (x y : B) (f : x --> y),
       pred_ob D f
       →
       internal_sfib f.

  Definition contained_in_sopfib
    : UU
    := ∏ (x y : B) (f : x --> y),
       pred_ob D f
       →
       internal_sopfib f.

  Definition contained_in_faithful
    : UU
    := ∏ (x y : B) (f : x --> y),
       pred_ob D f
       →
       faithful_1cell f.

  Definition contained_in_conservative
    : UU
    := ∏ (x y : B) (f : x --> y),
       pred_ob D f
       →
       conservative_1cell f.

  Definition contained_in_discrete
    : UU
    := ∏ (x y : B) (f : x --> y),
       pred_ob D f
       →
       discrete_1cell f.

  Definition discrete_contained_in_faithful
             (H : contained_in_discrete)
    : contained_in_faithful.
  Proof.
    intros x y f Hf.
    exact (pr1 (H x y f Hf)).
  Defined.

  Definition discrete_contained_in_conservative
             (H : contained_in_discrete)
    : contained_in_conservative.
  Proof.
    intros x y f Hf.
    exact (pr2 (H x y f Hf)).
  Defined.

  Definition pred_mor_is_mor_preserves_cartesian
    : UU
    := ∏ (e₁ e₂ b₁ b₂ : B)
         (p₁ : e₁ --> b₁)
         (p₂ : e₂ --> b₂)
         (fe : e₁ --> e₂),
       (pred_mor D p₁ p₂ fe
        →
        mor_preserves_cartesian p₁ p₂ fe)
       ×
       (mor_preserves_cartesian p₁ p₂ fe
        →
        pred_mor D p₁ p₂ fe).

  Definition pred_mor_is_mor_preserves_opcartesian
    : UU
    := ∏ (e₁ e₂ b₁ b₂ : B)
         (p₁ : e₁ --> b₁)
         (p₂ : e₂ --> b₂)
         (fe : e₁ --> e₂),
       (pred_mor D p₁ p₂ fe
        →
        mor_preserves_opcartesian p₁ p₂ fe)
       ×
       (mor_preserves_opcartesian p₁ p₂ fe
        →
        pred_mor D p₁ p₂ fe).
End DispMapBicat.

Definition disp_map_bicat
           (B : bicat)
  : UU
  := ∑ (D : arrow_subbicat B),
     closed_under_pb D
     ×
     contains_pb D
     ×
     closed_under_pb_ump_mor D.

Coercion disp_map_bicat_to_arrow_subbicat
         {B : bicat}
         (D : disp_map_bicat B)
  : arrow_subbicat B
  := pr1 D.

Section Projections.
  Context {B : bicat}
          (D : disp_map_bicat B).

  Definition pb_preserves_pred_ob
             {pb x y z : B}
             {f : x --> z}
             {g : y --> z}
             {p₁ : pb --> x}
             {p₂ : pb --> y}
             {γ : invertible_2cell (p₁ · f) (p₂ · g)}
             (Hf : pred_ob D f)
             (pb_sqr : has_pb_ump (make_pb_cone pb p₁ p₂ γ))
    : pred_ob D p₂
    := pr1 (pr12 D pb x y z f g p₁ p₂ γ Hf pb_sqr).

  Definition mor_of_pb_preserves_pred_ob
             {pb x y z : B}
             {f : x --> z}
             {g : y --> z}
             {p₁ : pb --> x}
             {p₂ : pb --> y}
             {γ : invertible_2cell (p₁ · f) (p₂ · g)}
             (Hf : pred_ob D f)
             (pb_sqr : has_pb_ump (make_pb_cone pb p₁ p₂ γ))
    : pred_mor (pr1 D) p₂ f p₁
    := pr2 (pr12 D pb x y z f g p₁ p₂ γ Hf pb_sqr).

  Definition pb_ob_of_pred_ob
             {x y z : B}
             (f : x --> z)
             (g : y --> z)
             (Hf : pred_ob D f)
    : B
    := pr1 (pr122 D x y z f g Hf).

  Definition pb_pr1_of_pred_ob
             {x y z : B}
             (f : x --> z)
             (g : y --> z)
             (Hf : pred_ob D f)
    : pb_ob_of_pred_ob f g Hf --> x
    := pr12 (pr122 D x y z f g Hf).

  Definition pb_pr2_of_pred_ob
             {x y z : B}
             (f : x --> z)
             (g : y --> z)
             (Hf : pred_ob D f)
    : pb_ob_of_pred_ob f g Hf --> y
    := pr122 (pr122 D x y z f g Hf).

  Definition pb_cell_of_pred_ob
             {x y z : B}
             (f : x --> z)
             (g : y --> z)
             (Hf : pred_ob D f)
    : invertible_2cell
        (pb_pr1_of_pred_ob f g Hf · f)
        (pb_pr2_of_pred_ob f g Hf · g)
    := pr1 (pr222 (pr122 D x y z f g Hf)).

  Definition pb_cone_of_pred_ob
             {x y z : B}
             (f : x --> z)
             (g : y --> z)
             (Hf : pred_ob D f)
    : pb_cone f g
    := make_pb_cone
         (pb_ob_of_pred_ob f g Hf)
         (pb_pr1_of_pred_ob f g Hf)
         (pb_pr2_of_pred_ob f g Hf)
         (pb_cell_of_pred_ob f g Hf).

  Definition pb_of_pred_ob_has_pb_ump
             {x y z : B}
             (f : x --> z)
             (g : y --> z)
             (Hf : pred_ob D f)
    : has_pb_ump (pb_cone_of_pred_ob f g Hf)
    := pr2 (pr222 (pr122 D x y z f g Hf)).

  Definition pred_mor_closed_under_pb_ump_mor
    : closed_under_pb_ump_mor D
    := pr222 D.
End Projections.

Definition make_disp_map_bicat
           {B : bicat}
           (D : arrow_subbicat B)
           (closed_pb : closed_under_pb D)
           (contains_pb : contains_pb D)
           (closed_pb_mor : closed_under_pb_ump_mor D)
  : disp_map_bicat B
  := (D ,, closed_pb ,, contains_pb ,, closed_pb_mor).

Definition make_disp_map_bicat_with_pb
           (B : bicat_with_pb)
           (D : arrow_subbicat B)
           (closed_pb : closed_under_pb D)
           (closed_pb_mor : closed_under_pb_ump_mor D)
  : disp_map_bicat B.
Proof.
  refine (make_disp_map_bicat D closed_pb _ closed_pb_mor).
  intros x y z f g p.
  pose (cone := pr1 (pr2 B x y z f g)).
  pose (pb_ump := pr2 (pr2 B x y z f g)).
  simple refine (_ ,, _ ,, _ ,, _ ,, _).
  - exact cone.
  - exact (pb_cone_pr1 cone).
  - exact (pb_cone_pr2 cone).
  - exact (pb_cone_cell cone).
  - exact pb_ump.
Defined.

(**
 4. Examples of display map bicategories
 *)
Definition full_disp_map_bicat
           {B : bicat_with_pb}
           (P₀ : ∏ (x y : B), x --> y → UU)
           (closed_pb : ∏ (pb x y z : B)
                          (f : x --> z)
                          (g : y --> z)
                          (p₁ : pb --> x)
                          (p₂ : pb --> y)
                          (γ : invertible_2cell (p₁ · f) (p₂ · g)),
                        P₀ x z f
                        →
                        has_pb_ump (make_pb_cone pb p₁ p₂ γ)
                        →
                        P₀ pb y p₂)
  : disp_map_bicat B.
Proof.
  use make_disp_map_bicat_with_pb.
  - exact (full_arrow_subbicat P₀).
  - exact (λ pb x y z f g p₁ p₂ γ H₁ H₂,
           closed_pb pb x y z f g p₁ p₂ γ H₁ H₂
           ,,
           tt).
  - exact (λ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _, tt).
Defined.

Definition intersection_disp_map_bicat
           {B : bicat}
           (D₁ D₂ : disp_map_bicat B)
  : disp_map_bicat B.
Proof.
  use make_disp_map_bicat.
  - exact (intersection_arrow_subbicat D₁ D₂).
  - intros ? ? ? ? ? ? ? ? ? Hf pb_sqr.
    split ; split.
    + exact (pb_preserves_pred_ob D₁ (pr1 Hf) pb_sqr).
    + exact (pb_preserves_pred_ob D₂ (pr2 Hf) pb_sqr).
    + exact (mor_of_pb_preserves_pred_ob D₁ (pr1 Hf) pb_sqr).
    + exact (mor_of_pb_preserves_pred_ob D₂ (pr2 Hf) pb_sqr).
  - intros x y z f g H.
    exact (pr122 D₁ _ _ _ _ _ (pr1 H)).
  - intros ? ? ? ? ? ? ? ? ? pb_sqr ? ? ? ? ? ? ? Hf Hp₁ Hcp₁.
    split.
    + exact (pred_mor_closed_under_pb_ump_mor
               D₁
               _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
               (pr1 Hf) (pr1 Hp₁) (pr1 Hcp₁)).
    + exact (pred_mor_closed_under_pb_ump_mor
               D₂
               _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _
               (pr2 Hf) (pr2 Hp₁) (pr2 Hcp₁)).
Defined.

Definition faithful_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B.
Proof.
  use full_disp_map_bicat.
  - exact (λ _ _ f, faithful_1cell f).
  - intros pb x y z f g p₁ p₂ γ Hf Hpb.
    exact (pb_of_faithful_1cell Hpb Hf).
Defined.

Definition fully_faithful_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B.
Proof.
  use full_disp_map_bicat.
  - exact (λ _ _ f, fully_faithful_1cell f).
  - intros pb x y z f g p₁ p₂ γ Hf Hpb.
    exact (pb_of_fully_faithful_1cell Hpb Hf).
Defined.

Definition pseudomonic_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B.
Proof.
  use full_disp_map_bicat.
  - exact (λ _ _ f, pseudomonic_1cell f).
  - intros pb x y z f g p₁ p₂ γ Hf Hpb.
    exact (pb_of_pseudomonic_1cell Hpb Hf).
Defined.

Definition conservative_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B.
Proof.
  use full_disp_map_bicat.
  - exact (λ _ _ f, conservative_1cell f).
  - intros pb x y z f g p₁ p₂ γ Hf Hpb.
    exact (pb_of_conservative_1cell Hpb Hf).
Defined.

Definition discrete_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B.
Proof.
  use full_disp_map_bicat.
  - exact (λ _ _ f, discrete_1cell f).
  - intros pb x y z f g p₁ p₂ γ Hf Hpb.
    exact (pb_of_discrete_1cell Hpb Hf).
Defined.

Definition sfib_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B.
Proof.
  use make_disp_map_bicat_with_pb.
  - exact (sfib_subbicat B).
  - intros pb x y z f g p₁ p₂ γ q Hpb.
    split.
    + exact (pb_of_sfib Hpb q).
    + exact (mor_preserves_cartesian_pb_pr1 Hpb q).
  - intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? H₁ H₂ H₃.
    apply mor_preserves_cartesian_pb_ump_mor.
    exact H₃.
Defined.

Definition sopfib_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B.
Proof.
  use make_disp_map_bicat_with_pb.
  - exact (sopfib_subbicat B).
  - intros pb x y z f g p₁ p₂ γ q Hpb.
    split.
    + exact (pb_of_sopfib Hpb q).
    + exact (mor_preserves_opcartesian_pb_pr1 Hpb q).
  - intros ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? H₁ H₂ H₃.
    apply mor_preserves_opcartesian_pb_ump_mor.
    exact H₃.
Defined.

Definition discrete_sfib_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B
  := intersection_disp_map_bicat
       (sfib_disp_map_bicat B)
       (discrete_disp_map_bicat B).

Definition discrete_sfib_disp_map_bicat_in_discrete
           (B : bicat)
  : contained_in_discrete (discrete_sfib_subbicat B).
Proof.
  intros x y f Hf.
  exact (pr2 Hf).
Defined.

Definition discrete_sopfib_disp_map_bicat
           (B : bicat_with_pb)
  : disp_map_bicat B
  := intersection_disp_map_bicat
       (sopfib_disp_map_bicat B)
       (discrete_disp_map_bicat B).

Definition discrete_sopfib_disp_map_bicat_in_discrete
           (B : bicat)
  : contained_in_discrete (discrete_sopfib_subbicat B).
Proof.
  intros x y f Hf.
  exact (pr2 Hf).
Defined.

(**
 5. Properties of display map bicategories
 *)
Definition is_covariant_disp_map_bicat
           {B : bicat}
           (D : disp_map_bicat B)
  : UU
  := contained_in_sopfib D
     ×
     pred_mor_is_mor_preserves_opcartesian D.

Definition is_contravariant_disp_map_bicat
           {B : bicat}
           (D : disp_map_bicat B)
  : UU
  := contained_in_sfib D
     ×
     pred_mor_is_mor_preserves_cartesian D.

Definition intersection_is_covariant
           {B : bicat}
           {D₁ D₂ : disp_map_bicat B}
           (HD₁ : is_covariant_disp_map_bicat D₁)
           (HD₂ : is_covariant_disp_map_bicat D₂)
  : is_covariant_disp_map_bicat (intersection_disp_map_bicat D₁ D₂).
Proof.
  split.
  - intros x y f Hf.
    apply HD₁.
    apply Hf.
  - intros e₁ e₂ b₁ b₂ p₁ p₂ fe.
    split.
    + intro H.
      apply HD₁.
      apply H.
    + intro H.
      split.
      * apply HD₁.
        apply H.
      * apply HD₂.
        apply H.
Defined.

Definition intersection_with_full_is_covariant
           {B : bicat_with_pb}
           (P₀ : ∏ (x y : B), x --> y → UU)
           (closed_pb : ∏ (pb x y z : B)
                          (f : x --> z)
                          (g : y --> z)
                          (p₁ : pb --> x)
                          (p₂ : pb --> y)
                          (γ : invertible_2cell (p₁ · f) (p₂ · g)),
                        P₀ x z f
                        →
                        has_pb_ump (make_pb_cone pb p₁ p₂ γ)
                        →
                        P₀ pb y p₂)
           {D : disp_map_bicat B}
           (HD : is_covariant_disp_map_bicat D)
  : is_covariant_disp_map_bicat
      (intersection_disp_map_bicat
         D
         (full_disp_map_bicat P₀ closed_pb)).
Proof.
  split.
  - intros x y f Hf.
    apply HD.
    apply Hf.
  - intros e₁ e₂ b₁ b₂ p₁ p₂ fe.
    split.
    + intro H.
      apply HD.
      apply H.
    + intro H.
      split.
      * apply HD.
        apply H.
      * exact tt.
Defined.

Definition intersection_is_contravariant
           {B : bicat}
           {D₁ D₂ : disp_map_bicat B}
           (HD₁ : is_contravariant_disp_map_bicat D₁)
           (HD₂ : is_contravariant_disp_map_bicat D₂)
  : is_contravariant_disp_map_bicat (intersection_disp_map_bicat D₁ D₂).
Proof.
  split.
  - intros x y f Hf.
    apply HD₁.
    apply Hf.
  - intros e₁ e₂ b₁ b₂ p₁ p₂ fe.
    split.
    + intro H.
      apply HD₁.
      apply H.
    + intro H.
      split.
      * apply HD₁.
        apply H.
      * apply HD₂.
        apply H.
Defined.

Definition intersection_with_full_is_contravariant
           {B : bicat_with_pb}
           (P₀ : ∏ (x y : B), x --> y → UU)
           (closed_pb : ∏ (pb x y z : B)
                          (f : x --> z)
                          (g : y --> z)
                          (p₁ : pb --> x)
                          (p₂ : pb --> y)
                          (γ : invertible_2cell (p₁ · f) (p₂ · g)),
                        P₀ x z f
                        →
                        has_pb_ump (make_pb_cone pb p₁ p₂ γ)
                        →
                        P₀ pb y p₂)
           {D : disp_map_bicat B}
           (HD : is_contravariant_disp_map_bicat D)
  : is_contravariant_disp_map_bicat
      (intersection_disp_map_bicat
         D
         (full_disp_map_bicat P₀ closed_pb)).
Proof.
  split.
  - intros x y f Hf.
    apply HD.
    apply Hf.
  - intros e₁ e₂ b₁ b₂ p₁ p₂ fe.
    split.
    + intro H.
      apply HD.
      apply H.
    + intro H.
      split.
      * apply HD.
        apply H.
      * exact tt.
Defined.

Definition sopfib_disp_map_bicat_is_covariant
           (B : bicat_with_pb)
  : is_covariant_disp_map_bicat (sopfib_disp_map_bicat B).
Proof.
  split.
  - intros ? ? ? H.
    exact H.
  - intros ? ? ? ? ? ? ?.
    split.
    + exact (λ H, H).
    + exact (λ H, H).
Defined.

Definition sfib_disp_map_bicat_is_contravariant
           (B : bicat_with_pb)
  : is_contravariant_disp_map_bicat (sfib_disp_map_bicat B).
Proof.
  split.
  - intros ? ? ? H.
    exact H.
  - intros ? ? ? ? ? ? ?.
    split.
    + exact (λ H, H).
    + exact (λ H, H).
Defined.

Definition discrete_sopfib_disp_map_bicat_is_covariant
           (B : bicat_with_pb)
  : is_covariant_disp_map_bicat (discrete_sopfib_disp_map_bicat B).
Proof.
  use intersection_with_full_is_covariant.
  split.
  - intros ? ? ? H.
    exact H.
  - intros ? ? ? ? ? ? ?.
    split.
    + exact (λ H, H).
    + exact (λ H, H).
Defined.

Definition discrete_sfib_disp_map_bicat_is_covariant
           (B : bicat_with_pb)
  : is_contravariant_disp_map_bicat (discrete_sfib_disp_map_bicat B).
Proof.
  use intersection_with_full_is_contravariant.
  split.
  - intros ? ? ? H.
    exact H.
  - intros ? ? ? ? ? ? ?.
    split.
    + exact (λ H, H).
    + exact (λ H, H).
Defined.

(**
 5. Closure conditions for display map bicategories
 *)
Definition arrow_subbicat_bifinal
           {B : bicat}
           (D : arrow_subbicat B)
  : UU
  := (∏ (b : B), pred_ob D (id₁ b))
     ×
     (∏ (e b : B)
        (h : e --> b),
      pred_mor D h (id₁ b) h).

Definition arrow_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (D : arrow_subbicat B)
  : UU
  := (∏ (b : B), pred_ob D (is_biinitial_1cell_property (pr2 I) b))
     ×
     (∏ (e b : B)
        (h : e --> b),
      pred_mor
        D
        (is_biinitial_1cell_property (pr2 I) b)
        h
        (is_biinitial_1cell_property (pr2 I) e)).

Definition arrow_subbicat_closed_composition
           {B : bicat}
           (D : arrow_subbicat B)
  : UU
  := (∏ (x y z : B)
        (f : x --> y)
        (g : y --> z),
      pred_ob D f
      →
      pred_ob D g
      →
      pred_ob D (f · g))
     ×
     (∏ (x y z : B)
        (f : x --> y)
        (g : y --> z),
      pred_ob D f
      →
      pred_ob D g
      →
      pred_mor D (f · g) g f).

Definition arrow_subbicat_closed_prod_mor
           {B : bicat}
           (D : arrow_subbicat B)
  : UU
  := ∏ (pb x y z : B)
       (f : x --> z)
       (g : y --> z)
       (p₁ : pb --> x)
       (p₂ : pb --> y)
       (γ : invertible_2cell (p₁ · f) (p₂ · g))
       (H : has_pb_ump (make_pb_cone pb p₁ p₂ γ))
       (c : B)
       (cp : c --> x)
       (h : c --> y)
       (δ : invertible_2cell (cp · f) (h · g))
       (cone := make_pb_cone c cp h δ),
     pred_ob D f
     →
     pred_mor D (cp · f) f cp
     →
     pred_mor D (cp · f) g h
     →
     pred_mor D (cp · f) (p₁ · f) (pb_ump_mor H cone).

(**
 6. Examples
 *)

(**
 6.1 Bifinal
 *)
Definition full_arrow_subbicat_bifinal
           {B : bicat}
           (P : ∏ (x y : B), x --> y → UU)
           (Pid : ∏ (x : B), P x x (id₁ x))
  : arrow_subbicat_bifinal (full_arrow_subbicat P).
Proof.
  split.
  - exact Pid.
  - exact (λ _ _ _, tt).
Defined.

Definition intersection_arrow_subbicat_bifinal
           {B : bicat}
           (D₁ D₂ : arrow_subbicat B)
           (HD₁ : arrow_subbicat_bifinal D₁)
           (HD₂ : arrow_subbicat_bifinal D₂)
  : arrow_subbicat_bifinal (intersection_arrow_subbicat D₁ D₂).
Proof.
  split.
  - intro b.
    split.
    + apply HD₁.
    + apply HD₂.
  - intros e b h.
    split.
    + apply HD₁.
    + apply HD₂.
Defined.

Definition faithful_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (faithful_subbicat B).
Proof.
  use full_arrow_subbicat_bifinal.
  intros ; cbn.
  apply id1_faithful.
Defined.

Definition fully_faithful_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (fully_faithful_subbicat B).
Proof.
  use full_arrow_subbicat_bifinal.
  intros ; cbn.
  apply id1_fully_faithful.
Defined.

Definition pseudomonic_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (pseudomonic_subbicat B).
Proof.
  use full_arrow_subbicat_bifinal.
  intros ; cbn.
  apply id1_pseudomonic.
Defined.

Definition conservative_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (conservative_subbicat B).
Proof.
  use full_arrow_subbicat_bifinal.
  intros ; cbn.
  apply id1_conservative.
Defined.

Definition discrete_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (discrete_subbicat B).
Proof.
  use full_arrow_subbicat_bifinal.
  intros ; cbn.
  apply id1_discrete.
Defined.

Definition sfib_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (sfib_subbicat B).
Proof.
  split.
  - exact identity_internal_sfib.
  - intros.
    apply mor_to_id_preserves_cartesian.
Defined.

Definition sopfib_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (sopfib_subbicat B).
Proof.
  split.
  - exact identity_internal_sopfib.
  - intros.
    apply mor_to_id_preserves_opcartesian.
Defined.

Definition discrete_sfib_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (discrete_sfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_bifinal.
  - exact (sfib_subbicat_bifinal B).
  - exact (discrete_subbicat_bifinal B).
Defined.

Definition discrete_sopfib_subbicat_bifinal
           (B : bicat)
  : arrow_subbicat_bifinal (discrete_sopfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_bifinal.
  - exact (sopfib_subbicat_bifinal B).
  - exact (discrete_subbicat_bifinal B).
Defined.

(**
 6.2 Biinitial
 *)
Definition full_arrow_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (P : ∏ (x y : B), x --> y → UU)
           (PI : ∏ (x : B), P (pr1 I) x (is_biinitial_1cell_property (pr2 I) x))
  : arrow_subbicat_biinitial I (full_arrow_subbicat P).
Proof.
  split.
  - exact PI.
  - exact (λ _ _ _, tt).
Defined.

Definition intersection_arrow_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (D₁ D₂ : arrow_subbicat B)
           (HD₁ : arrow_subbicat_biinitial I D₁)
           (HD₂ : arrow_subbicat_biinitial I D₂)
  : arrow_subbicat_biinitial I (intersection_arrow_subbicat D₁ D₂).
Proof.
  split.
  - intro b.
    split.
    + apply HD₁.
    + apply HD₂.
  - intros e b h.
    split.
    + apply HD₁.
    + apply HD₂.
Defined.

Definition faithful_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (faithful_subbicat B).
Proof.
  use full_arrow_subbicat_biinitial.
  intros ; cbn.
  exact (from_biinitial_faithful_1cell (pr2 I) HI _).
Defined.

Definition fully_faithful_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (fully_faithful_subbicat B).
Proof.
  use full_arrow_subbicat_biinitial.
  intros ; cbn.
  exact (from_biinitial_fully_faithful_1cell (pr2 I) HI _).
Defined.

Definition pseudomonic_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (pseudomonic_subbicat B).
Proof.
  use full_arrow_subbicat_biinitial.
  intros ; cbn.
  exact (from_biinitial_pseudomonic_1cell (pr2 I) HI _).
Defined.

Definition conservative_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (conservative_subbicat B).
Proof.
  use full_arrow_subbicat_biinitial.
  intros ; cbn.
  exact (from_biinitial_conservative_1cell (pr2 I) HI _).
Defined.

Definition discrete_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (discrete_subbicat B).
Proof.
  use full_arrow_subbicat_biinitial.
  intros ; cbn.
  exact (from_biinitial_discrete_1cell (pr2 I) HI _).
Defined.

Definition sfib_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (sfib_subbicat B).
Proof.
  split.
  - exact (λ _, from_biinitial_internal_sfib (pr2 I) HI _).
  - intros.
    apply from_biinitial_mor_preserves_cartesian.
    exact HI.
Defined.

Definition sopfib_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (sopfib_subbicat B).
Proof.
  split.
  - exact (λ _, from_biinitial_internal_sopfib (pr2 I) HI _).
  - intros.
    apply from_biinitial_mor_preserves_opcartesian.
    exact HI.
Defined.

Definition discrete_sfib_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (discrete_sfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_biinitial.
  - exact (sfib_subbicat_biinitial I HI).
  - exact (discrete_subbicat_biinitial I HI).
Defined.

Definition discrete_sopfib_subbicat_biinitial
           {B : bicat}
           (I : biinitial_obj B)
           (HI : biinitial_is_strict_biinitial_obj (pr2 I))
  : arrow_subbicat_biinitial I (discrete_sopfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_biinitial.
  - exact (sopfib_subbicat_biinitial I HI).
  - exact (discrete_subbicat_biinitial I HI).
Defined.

(**
 6.3 Composition
 *)
Definition full_arrow_subbicat_composition
           {B : bicat}
           (P : ∏ (x y : B), x --> y → UU)
           (Pcomp : ∏ (x y z : B)
                      (f : x --> y)
                      (g : y --> z),
                    P x y f
                    →
                    P y z g
                    →
                    P x z (f · g))
  : arrow_subbicat_closed_composition (full_arrow_subbicat P).
Proof.
  split.
  - exact Pcomp.
  - intros.
    apply tt.
Defined.

Definition intersection_arrow_subbicat_composition
           {B : bicat}
           (D₁ D₂ : arrow_subbicat B)
           (HD₁ : arrow_subbicat_closed_composition D₁)
           (HD₂ : arrow_subbicat_closed_composition D₂)
  : arrow_subbicat_closed_composition (intersection_arrow_subbicat D₁ D₂).
Proof.
  split.
  - intros x y z f g Hf Hg.
    split.
    + apply HD₁.
      * exact (pr1 Hf).
      * exact (pr1 Hg).
    + apply HD₂.
      * exact (pr2 Hf).
      * exact (pr2 Hg).
  - intros x y z f g Hf Hg.
    split.
    + apply HD₁.
      * exact (pr1 Hf).
      * exact (pr1 Hg).
    + apply HD₂.
      * exact (pr2 Hf).
      * exact (pr2 Hg).
Defined.

Definition faithful_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (faithful_subbicat B).
Proof.
  use full_arrow_subbicat_composition.
  intros x y z f g Hf Hg.
  exact (comp_faithful Hf Hg).
Defined.

Definition fully_faithful_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (fully_faithful_subbicat B).
Proof.
  use full_arrow_subbicat_composition.
  intros x y z f g Hf Hg.
  exact (comp_fully_faithful Hf Hg).
Defined.

Definition pseudomonic_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (pseudomonic_subbicat B).
Proof.
  use full_arrow_subbicat_composition.
  intros x y z f g Hf Hg.
  exact (comp_pseudomonic Hf Hg).
Defined.

Definition conservative_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (conservative_subbicat B).
Proof.
  use full_arrow_subbicat_composition.
  intros x y z f g Hf Hg.
  exact (comp_conservative Hf Hg).
Defined.

Definition discrete_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (discrete_subbicat B).
Proof.
  use full_arrow_subbicat_composition.
  intros x y z f g Hf Hg.
  exact (comp_discrete Hf Hg).
Defined.

Definition sfib_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (sfib_subbicat B).
Proof.
  split.
  - intros x y z f g Hf Hg.
    exact (comp_sfib Hf Hg).
  - intros x y z f g Hf Hg ; cbn.
    apply comp_mor_preserves_cartesian.
    + exact Hf.
    + exact Hg.
Defined.

Definition sopfib_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (sopfib_subbicat B).
Proof.
  split.
  - intros x y z f g Hf Hg.
    exact (comp_sopfib Hf Hg).
  - intros x y z f g Hf Hg ; cbn.
    apply comp_mor_preserves_opcartesian.
    + exact Hf.
    + exact Hg.
Defined.

Definition discrete_sfib_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (discrete_sfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_composition.
  - exact (sfib_subbicat_closed_composition B).
  - exact (discrete_subbicat_closed_composition B).
Defined.

Definition discrete_sopfib_subbicat_closed_composition
           (B : bicat)
  : arrow_subbicat_closed_composition (discrete_sopfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_composition.
  - exact (sopfib_subbicat_closed_composition B).
  - exact (discrete_subbicat_closed_composition B).
Defined.

(**
 6.4 Product morphism
 *)
Definition full_arrow_subbicat_closed_prod_mor
           {B : bicat}
           (P : ∏ (x y : B), x --> y → UU)
  : arrow_subbicat_closed_prod_mor (full_arrow_subbicat P).
Proof.
  intro ; intros.
  exact tt.
Defined.

Definition intersection_arrow_subbicat_closed_prod_mor
           {B : bicat}
           (D₁ D₂ : arrow_subbicat B)
           (HD₁ : arrow_subbicat_closed_prod_mor D₁)
           (HD₂ : arrow_subbicat_closed_prod_mor D₂)
  : arrow_subbicat_closed_prod_mor (intersection_arrow_subbicat D₁ D₂).
Proof.
  intros pb x y z f g p₁ p₂ γ H c cp h δ cone Hf Hfmap Hgmap.
  split.
  - apply HD₁.
    + exact (pr1 Hf).
    + exact (pr1 Hfmap).
    + exact (pr1 Hgmap).
  - apply HD₂.
    + exact (pr2 Hf).
    + exact (pr2 Hfmap).
    + exact (pr2 Hgmap).
Defined.

Definition faithful_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (faithful_subbicat B).
Proof.
  apply full_arrow_subbicat_closed_prod_mor.
Defined.

Definition fully_faithful_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (fully_faithful_subbicat B).
Proof.
  apply full_arrow_subbicat_closed_prod_mor.
Defined.

Definition pseudomonic_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (pseudomonic_subbicat B).
Proof.
  apply full_arrow_subbicat_closed_prod_mor.
Defined.

Definition conservative_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (conservative_subbicat B).
Proof.
  apply full_arrow_subbicat_closed_prod_mor.
Defined.

Definition discrete_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (discrete_subbicat B).
Proof.
  apply full_arrow_subbicat_closed_prod_mor.
Defined.

Definition sfib_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (sfib_subbicat B).
Proof.
  intros pb x y z f g p₁ p₂ γ H c cp h δ cone Hf Hfmap Hgmap.
  exact (mor_preserves_cartesian_pb_ump_mor_comp H Hf δ Hfmap Hgmap).
Defined.

Definition sopfib_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (sopfib_subbicat B).
Proof.
  intros pb x y z f g p₁ p₂ γ H c cp h δ cone Hf Hfmap Hgmap.
  exact (mor_preserves_opcartesian_pb_ump_mor_comp H Hf δ Hfmap Hgmap).
Defined.

Definition discrete_sfib_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (discrete_sfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_closed_prod_mor.
  - exact (sfib_subbicat_closed_prod_mor B).
  - exact (discrete_subbicat_closed_prod_mor B).
Defined.

Definition discrete_sopfib_subbicat_closed_prod_mor
           (B : bicat)
  : arrow_subbicat_closed_prod_mor (discrete_sopfib_subbicat B).
Proof.
  use intersection_arrow_subbicat_closed_prod_mor.
  - exact (sopfib_subbicat_closed_prod_mor B).
  - exact (discrete_subbicat_closed_prod_mor B).
Defined.


Require Import Coq.Lists.List.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Setoids.Setoid.

Global Instance list_rect_Proper_dep_gen {A P} (RP : forall x : list A, P x -> P x -> Prop)
  : Proper (RP nil ==> forall_relation (fun x => forall_relation (fun xs => RP xs ==> RP (cons x xs))) ==> forall_relation RP) (@list_rect A P) | 10.
Proof.
  cbv [forall_relation respectful]; intros N N' HN C C' HC ls.
  induction ls as [|l ls IHls]; cbn [list_rect];
    repeat first [ apply IHls | apply HC | apply HN | progress intros | reflexivity ].
Qed.
Global Instance list_rect_Proper_dep {A P} : Proper (eq ==> forall_relation (fun _ => forall_relation (fun _ => forall_relation (fun _ => eq))) ==> forall_relation (fun _ => eq)) (@list_rect A P) | 1.
Proof.
  cbv [forall_relation respectful Proper]; intros; eapply (@list_rect_Proper_dep_gen A P (fun _ => eq)); cbv [forall_relation respectful]; intros; subst; eauto.
Qed.
Global Instance list_rect_Proper_gen {A P} R
  : Proper (R ==> (eq ==> eq ==> R ==> R) ==> eq ==> R) (@list_rect A (fun _ => P)) | 10.
Proof. repeat intro; subst; apply (@list_rect_Proper_dep_gen A (fun _ => P) (fun _ => R)); cbv [forall_relation respectful] in *; eauto. Qed.
Global Instance list_rect_Proper {A P} : Proper (eq ==> pointwise_relation _ (pointwise_relation _ (pointwise_relation _ eq)) ==> eq ==> eq) (@list_rect A (fun _ => P)).
Proof. repeat intro; subst; apply (@list_rect_Proper_dep A (fun _ => P)); eauto. Qed.


(**
Coqでcall/cc（Coqで継続モナド、その2）
===============================
2014_05_17 @suharahiromichi

2014_05_18 @suharahiromichi 「証明」の部分を見直した

継続モナドの続きとして、
前回（文献1.）にも定義してあったcall/ccを使ってみる。
例題は今回も文献2.からいただいています。

本資料のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/ssr/ssr_monad_callcc.v
*)

Require Import ssreflect ssrbool ssrnat seq.

(**
# 継続モナド

## 定義（再掲）
*)
Definition MCont R A := (A -> R) -> R.

Definition bind {R A : Type} (c : MCont R A)
           (f : A -> MCont R A) : MCont R A :=
  fun (k : A -> R) => c (fun (a : A) => f a k).

Definition ret {R A : Type} (a : A) : MCont R A :=
  fun k => k a.

(* call/cc、文献3の定義を参考にした。 *)
Definition callcc {R A B : Type}
           (f : (A -> MCont R B) -> MCont R A) : MCont R A :=
  fun (k : A -> R) => f (fun (a : A) => fun (b : B -> R) => k a) k.

Check callcc.

(**
    : ((A -> MCont R B) -> MCont R A) -> MCont R A

すこし強引だが、
call/ccの型は、「MCont R」の部分を除いて見ると、
古典論理を扱うときの「パースの公理」に対応するといえる。

    ((P -> Q) -> P) -> P
*)

(**
演算子と、
do記法も定義しておく。
*)
Notation "c >>= f" :=
  (bind c f)
    (at level 42, left associativity).

Notation "s1 >> s2" :=
  (s1 >>= fun _ => s2)
    (at level 42, left associativity).

Notation "'DO' a <- A ; b <- B ; C 'OD'" :=
  (A >>= fun a => B >>= fun b => C)
    (at level 100, no associativity).

Notation "'DO' A ; B ; C 'OD'" :=
  (A >> B >> C)
    (at level 100, no associativity).

(**
# 例題

## 大域脱出の例（文献2.）
 *)
Definition bar1 (cont : nat -> MCont nat nat) := ret 1 : MCont nat nat.
Definition bar2 (cont : nat -> MCont nat nat) := cont 2 : MCont nat nat.
Definition bar3 (cont : nat -> MCont nat nat) := ret 3 : MCont nat nat.

Definition foo (cont : nat -> MCont nat nat) :=
  DO
    bar1 cont;
    bar2 cont;                              (* !! *)
    bar3 cont
  OD.

Definition test := callcc (fun k => foo k) id.
Eval cbv in test.                           (* 2 *)

(**
## flatten list

2次元リストを1次元にする。ただし、空リストがあったら空リストを返す（文献2.）。
*)

(**
### モナドを使わない定義
 *)
Fixpoint flatten_cps (l : seq (seq nat)) : MCont (seq nat) (seq nat) :=
  fun cont =>
    match l with
      | [::]      => cont [::]
      | [::] :: _ => [::]                   (* !! *)
      | x :: xs   => flatten_cps xs (fun y => cont (x ++ y))
    end.

Eval cbv in flatten_cps [:: [:: 1;2];[:: 3;4];[:: 5;6]] id.      (* [:: 1; 2; 3; 4; 5; 6] *)
Eval cbv in flatten_cps [:: [:: 1;2];[:: 3;4];[::];[:: 5;6]] id. (* [::] *)
Eval cbv in flatten_cps [:: [:: 1;2];[::];[:: 3;4];[:: 5;6]] id. (* [::] *)

(**
### モナドを使う定義
 *)
Fixpoint flatten' (k : seq nat -> MCont (seq nat) (seq nat))
         (l : seq (seq nat)) : MCont (seq nat) (seq nat) :=
  match l with
    | [::]      => ret [::]
    | [::] :: _ => k [::]                   (* !! *)
    | x :: xs   => flatten' k xs >>= fun y => ret (x ++ y)
  end.

Definition flatten_callcc (l : seq (seq nat)) : MCont (seq nat) (seq nat) :=
  callcc (fun (k : seq nat -> MCont (seq nat) (seq nat)) => flatten' k l).

Eval cbv in flatten_callcc [:: [:: 1;2];[:: 3;4];[:: 5;6]] id.      (* [:: 1; 2; 3; 4; 5; 6] *)
Eval cbv in flatten_callcc [:: [:: 1;2];[:: 3;4];[::];[:: 5;6]] id. (* [::] *)
Eval cbv in flatten_callcc [:: [:: 1;2];[::];[:: 3;4];[:: 5;6]] id. (* [::] *)

(**
以上で、継続モナドに関連してのcall/ccの話は終わりである
（flatten_cpsとflatten_callccの等価の証明も大変そうなので）。
しかし、Coqでcall/ccという表題をつけたからには、
古典論理の定理をcall/ccを使って証明しなければいけないだろう。

# 二重否定の除去の証明

「二重否定の除去」とは、任意のP:Propに対して以下が成立することである。

    ~ ~ P -> P

ここで、~P は P->False であるから以下と同じである。

    ((P -> False) -> False) -> P

さらに、モナドを使ったcallccの定義にあわせて、モナドにしてみる（恣意的！）。

    (P -> MCont R False) -> MCont R False) -> MCont R P

「二重否定の除去」は古典論理の範疇に属する定理だから、
何かの規則を追加しないとCoqでは証明できない。
ここでは、callccを使うことで証明してみる。
*)

Axiom exfalso_with_monad :
  forall R (P : Prop), MCont R False -> MCont R P.

Theorem double_negative_elimination_joke :
  forall R (P : Prop),
    ((P -> MCont R False) -> MCont R False) -> MCont R P.
Proof.
  move=> R P HPFF.
  have HPFP : ((P -> MCont R False) -> MCont R P).
    move=> HPF.
    apply HPFF in HPF.
    by apply exfalso_with_monad.
  Check @callcc R P False.
  by apply (@callcc R P False) in HPFP.
Qed.

Print double_negative_elimination_joke.
(**
中身は以下のようなものである。実行してもなにも出てこない。

    double_negative_elimination_joke =
    fun (R : Type) (P : Prop) (HPFF : (P -> MCont R False) -> MCont R False) =>
    ssr_have ((P -> MCont R False) -> MCont R P)
      (fun HPF : P -> MCont R False =>
       (fun HPF0 : MCont R False => exfalso_with_monad R P HPF0) (HPFF HPF))
      (fun HPFP : (P -> MCont R False) -> MCont R P =>
       (fun HPFP0 : MCont R P => HPFP0) (callcc HPFP))
         : forall (R : Type) (P : Prop),
           ((P -> MCont R False) -> MCont R False) -> MCont R P
*)

(**
本章の内容は半ば冗談である。
二重否定除去はパースの公理：
*)
Axiom peirce : forall P Q : Prop, ((P -> Q) -> P) -> P.
(**
を使って証明できる（文献4. 練習問題: classical_axioms）。
なので、上記のように変形をしておけば、callccで
証明できるのは当然である。
*)

(**
補足説明：
この資料の最初の版では「証明」以下のようにしていた。
*)
Theorem double_negative_elimination_joke' :
  forall R (P : Prop),
    ((P -> MCont R False) -> MCont R False) -> MCont R P.
Proof.
  move=> R P HPFF.
  Check @callcc.       (* callccの暗黙の引数 R,A,B に対して、それぞれ *)
  Check @callcc R P False.                  (* R,P,False を与える。 *)
  Check @callcc R False P.                  (* R,False,P を与える。 *)

  apply (@callcc R P False) => HPF.
  apply exfalso_with_monad.
  apply (@callcc R False P) => HFP.
    by apply HPFF, HPF.
Qed.
(**
この場合、証明には、

    @callcc R False P : (False -> P) -> False -> False

も必要としていて、「call/ccで証明した」とは言い難かった。
証明を見直すにあたって文献5.を参考にさせていただいた。
*)

(**
補足説明：
パースの公理を使った「二重否定除去」の証明を以下に示す。
*)
Theorem double_negative_elimination : forall P, ~ ~ P -> P.
Proof.
  move=> P H.
  apply (peirce P False) => H1.
  elim: H.
  rewrite /not.
  by apply H1.
Qed.
Print  double_negative_elimination.

(**
# 文献

1. Coqで継続モナド
   http://qiita.com/suharahiromichi/items/f07f932103c28f36dd0e

2. お気楽 Haskell プログラミング入門 ●継続渡しスタイル
   http://www.geocities.jp/m_hiroi/func/haskell38.html

3. モナドのすべて Continuationモナド
   http://www.sampou.org/haskell/a-a-monads/html/contmonad.html

4. Pierce他、梅村他訳「ソフトウエアの基礎」、Coqにおける論理
   http://proofcafe.org/sf/Logic_J.html

5. Playing with Pointers Archived、Classical Axioms in Coq
   http://pwparchive.wordpress.com/2012/09/18/classical-axioms-in-coq-2/
*)

(* END *)