Require Import VST.floyd.proofauto.
Require Import VST.progs.bst_oo.

Open Scope logic.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_tree := Tstruct _tree noattr.

Section TREES.
Variable V : Type.
Variable default: V.

Definition key := Z.

Inductive tree : Type :=
 | E : tree
 | T: tree -> key -> V -> tree -> tree.

Definition empty_tree : tree := E.

(* insert if it is new *)
Fixpoint insert (x: key) (v: V) (s: tree) : tree :=
 match s with
 | E => T E x v E
 | T a y v' b => if  x <? y then T (insert x v a) y v' b
                        else if y <? x then T a y v' (insert x v b)
                        else T a x v' b
 end.

Fixpoint tree_inb (x: key) (s: tree) : bool :=
 match s with
 | E => false
 | T a y v' b => if  x <? y then tree_inb x a
                        else if y <? x then tree_inb x b
                        else true
 end.

Fixpoint pushdown_left (a: tree) (bc: tree) : tree :=
 match bc with
 | E => a
 | T b y vy c => T (pushdown_left a b) y vy c
 end.

Fixpoint delete (x: key) (s: tree) : tree :=
 match s with
 | E => E
 | T a y v' b => if  x <? y then T (delete x a) y v' b
                        else if y <? x then T a y v' (delete x b)
                        else pushdown_left a b
 end.

End TREES.

Arguments E {V}.
Arguments T {V} _ _ _ _.
Arguments insert {V} x v s.
Arguments tree_inb {V} x s.
Arguments pushdown_left {V} a bc.
Arguments delete {V} x s.

Fixpoint treebox_rep (t: tree val) (b: val) : mpred :=
  match t with
  | E => data_at Tsh (tptr t_struct_tree) nullval b
  | T l x p r =>
      !! (Int.min_signed <= x <= Int.max_signed) &&
      data_at Tsh (tptr t_struct_tree) p b *
      field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p *
      treebox_rep l (field_address t_struct_tree [StructField _left] p) *
      treebox_rep r (field_address t_struct_tree [StructField _right] p)
  end.

Fixpoint key_store (s: tree val) (x: key) (q: val): Prop :=
 match s with
 | E => False
 | T a y p b => if  x <? y then key_store a x q
                        else if y <? x then key_store b x q
                        else q = field_address t_struct_tree [StructField _value] p
 end.

Definition key_store_ (s: tree val) (x: key): Prop :=
  exists v, key_store s x v.

Definition value_at (t: tree val) (v: val) (x: Z): mpred :=
  EX q: val,
  !! (key_store t x q) &&
  data_at Tsh (tptr Tvoid) v q.

(* TODO: maybe not useful *)
Lemma treebox_rep_spec: forall (t: tree val) (b: val),
  treebox_rep t b =
  data_at Tsh (tptr t_struct_tree)
    match t return val with
    | E => nullval
    | T _ _ p _ => p
    end b *
  match t with
  | E => emp
  | T l x p r =>
      !! (Int.min_signed <= x <= Int.max_signed) &&
      field_at Tsh t_struct_tree [StructField _key] (Vint (Int.repr x)) p *
      treebox_rep l (field_address t_struct_tree [StructField _left] p) *
      treebox_rep r (field_address t_struct_tree [StructField _right] p)
  end.
Proof.
  intros.
  destruct t; simpl; apply pred_ext; entailer!.
Qed.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH n: Z
  PRE [ tint]
     PROP (4 <= n <= Int.max_unsigned)
     PARAMS (Vint (Int.repr n))
     SEP ()
  POST [ tptr tvoid ]
     EX v: val,
     PROP (malloc_compatible n v)
     RETURN (v)
     SEP (memory_block Tsh n v).

Definition freeN_spec :=
 DECLARE _freeN
  WITH p : val , n : Z
  PRE [ tptr tvoid , tint]
     (* we should also require natural_align_compatible (eval_id 1) *)
      PROP() PARAMS (p; Vint (Int.repr n))
      SEP (memory_block Tsh n p)
  POST [ tvoid ]
    PROP () RETURN () SEP ().

Definition treebox_new_spec :=
 DECLARE _treebox_new
  WITH u : unit
  PRE  [  ]
       PROP() PARAMS() SEP ()
  POST [ (tptr t_struct_tree) ]
    EX v:val,
    PROP()
    RETURN (v)
    SEP (data_at Tsh (tptr t_struct_tree) nullval v).

Definition subscr_spec :=
 DECLARE _subscr
  WITH b: val, x: Z, t: tree val
  PRE  [ tptr (tptr t_struct_tree), tint]
    PROP(Int.min_signed <= x <= Int.max_signed)
    PARAMS(b; Vint (Int.repr x))
    SEP (treebox_rep t b)
  POST [ tptr (tptr tvoid) ]
    EX p: val, EX q: val,
    PROP(key_store (insert x p t) x q)
    RETURN(q)
    SEP (treebox_rep (insert x p t) b;
         (!! key_store_ t x && emp) || (!! (~ key_store_ t x) && data_at Tsh (tptr tvoid) nullval q)).

(*
Definition subscr_spec1 :=
 DECLARE _subscr
  WITH b: val, x: Z, p: val, xs: Z -> Prop
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _key OF tint]
    PROP(xs x)
    LOCAL(temp _t b; temp _key (Vint (Int.repr x)))
    SEP (container_at xs b; key_store x p)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (container_at xs b; key_store x p).

Definition subscr_spec2 :=
 DECLARE _subscr
  WITH b: val, x: Z, p: val, xs: Z -> Prop
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _key OF tint]
    PROP(~ xs x; Int.min_signed <= x <= Int.max_signed)
    LOCAL(temp _t b; temp _key (Vint (Int.repr x)))
    SEP (container_at xs b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (container_at (fun x0 => xs x0 \/ x0 = x) b; key_store x p).
*)
Definition turn_left_spec :=
 DECLARE _turn_left
  WITH ta: tree val, x: Z, tb: tree val, y: Z, tc: tree val, b: val, l: val, r: val
  PRE  [ tptr (tptr (Tstruct _tree noattr)),
        tptr (Tstruct _tree noattr),
        tptr (Tstruct _tree noattr)]
    PROP()
    PARAMS(b; l; r)
    SEP (treebox_rep (T ta x l (T tb y r tc)) b)
  POST [ Tvoid ]
    PROP()
    RETURN()
    SEP (treebox_rep (T (T ta x l tb) y r tc) b).

Definition pushdown_left_spec :=
 DECLARE _pushdown_left
  WITH ta: tree val, x: Z, tb: tree val, b: val, p: val
  PRE  [ tptr (tptr (Tstruct _tree noattr))]
    PROP()
    PARAMS(b)
    SEP (treebox_rep (T ta x p tb) b)
  POST [ Tvoid ]
    PROP()
    RETURN()
    SEP (treebox_rep (pushdown_left ta tb) b).
(*
Definition delete_spec1 :=
 DECLARE _delete
  WITH b: val, x: Z, xs: Z -> Prop
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint]
    PROP(xs x)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (container_at xs b; value_at Vundef x)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (container_at (fun x0 => xs x0 /\ x0 <> x) b).

Definition delete_spec2 :=
 DECLARE _delete
  WITH b: val, x: Z, xs: Z -> Prop
  PRE  [ _t OF (tptr (tptr t_struct_tree)), _x OF tint]
    PROP(~ xs x)
    LOCAL(temp _t b; temp _x (Vint (Int.repr x)))
    SEP (container_at xs b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (container_at xs b).
*)
(*
Definition tree_free_spec :=
 DECLARE _tree_free
  WITH t: tree val, p: val
  PRE  [ _p OF (tptr t_struct_tree) ]
       PROP() LOCAL(temp _p p) SEP (tree_rep t p)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).

Definition treebox_free_spec :=
 DECLARE _treebox_free
  WITH t: tree val, b: val
  PRE  [ _b OF (tptr (tptr t_struct_tree)) ]
       PROP() LOCAL(temp _b b) SEP (treebox_rep t b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (emp).
*)
Definition Gprog : funspecs :=
    ltac:(with_library prog [
    mallocN_spec; freeN_spec; treebox_new_spec;
    subscr_spec; turn_left_spec; pushdown_left_spec
  ]).

Lemma treebox_rep_saturate_local:
   forall t b, treebox_rep t b |-- !! field_compatible (tptr t_struct_tree) [] b.
Proof.
intros.
destruct t.
+ simpl.
  entailer!.
+ simpl.
  entailer!.
Qed.

#[export] Hint Resolve treebox_rep_saturate_local: saturate_local.

(*
Lemma tree_rep_saturate_local:
   forall t p, tree_rep t p |-- !! is_pointer_or_null p.
Proof.
destruct t; simpl; intros.
entailer!.
Intros pa pb. entailer!.
Qed.

#[export] Hint Resolve tree_rep_saturate_local: saturate_local.

Lemma tree_rep_valid_pointer:
  forall t p, tree_rep t p |-- valid_pointer p.
Proof.
intros.
destruct t; simpl; normalize; auto with valid_pointer.
Qed.
#[export] Hint Resolve tree_rep_valid_pointer: valid_pointer.

*)
Lemma modus_ponens_wand' {A}{ND: NatDed A}{SL: SepLog A}:
  forall P Q R: A, P |-- Q -> P * (Q -* R) |-- R.
Proof.
  intros.
  eapply derives_trans; [| apply modus_ponens_wand].
  apply sepcon_derives; [| apply derives_refl].
  auto.
Qed.

Lemma RAMIF_Q2_trans' {X Y A : Type} {ND : NatDed A} {SL : SepLog A}:
  forall (m l: A) (g' m' l' : X -> Y -> A),
    m |-- l * (ALL p: X, ALL q: Y, l' p q -* m' p q) ->
    m * (ALL p: X, ALL q: Y, m' p q -* g' p q) |-- l * (ALL p: X, ALL q: Y, l' p q -* g' p q).
Proof.
  intros.
  eapply derives_trans; [apply sepcon_derives; [exact H | apply derives_refl] |].
  clear H.
  rewrite sepcon_assoc.
  apply sepcon_derives; auto.
  apply allp_right; intros p.
  apply allp_right; intros q.
  apply <- wand_sepcon_adjoint.
  apply (allp_left _ p), (allp_left _ q).
  apply -> wand_sepcon_adjoint.
  rewrite sepcon_comm.
  apply <- wand_sepcon_adjoint.
  apply (allp_left _ p), (allp_left _ q).
  apply -> wand_sepcon_adjoint.
  rewrite sepcon_comm.
  apply -> wand_sepcon_adjoint.
  rewrite (sepcon_comm (_ * _) _), <- sepcon_assoc.
  apply <- wand_sepcon_adjoint.
  eapply derives_trans; [apply modus_ponens_wand |].
  apply -> wand_sepcon_adjoint.
  apply modus_ponens_wand.
Qed.

Lemma if_trueb: forall {A: Type} b (a1 a2: A), b = true -> (if b then a1 else a2) = a1.
Proof. intros; subst; auto. Qed.

Lemma if_falseb: forall {A: Type} b (a1 a2: A), b = false -> (if b then a1 else a2) = a2.
Proof. intros; subst; auto. Qed.

Ltac simpl_compb :=
  match goal with
  | |- context [if Z.ltb ?x ?y then _ else _] =>
         first [ rewrite (if_trueb (Z.ltb x y)) by (apply Z.ltb_lt; lia)
               | rewrite (if_falseb (Z.ltb x y)) by (apply Z.ltb_ge; lia)]
  end.

Definition subscr_post (b0: val) (t0: tree val) (x: Z) (p: val) (q: val) :=
  !! key_store (insert x p t0) x q &&
  treebox_rep (insert x p t0) b0 *
  (if tree_inb x t0 then emp else data_at Tsh (tptr tvoid) nullval q).

Definition subscr_inv (b0: val) (t0: tree val) (x: Z): environ -> mpred :=
  EX b: val, EX t: tree val,
  PROP()
  LOCAL(temp _t b; temp _key (Vint (Int.repr x)))
  SEP(treebox_rep t b;
      ALL p: val, ALL q: val, subscr_post b t x p q -* subscr_post b0 t0 x p q).

Axiom tree_inb_true_iff: forall x (t: tree val), tree_inb x t = true <-> key_store_ t x.
Axiom tree_inb_false_iff: forall x (t: tree val), tree_inb x t = false <-> ~ key_store_ t x.

Lemma body_subscr: semax_body Vprog Gprog f_subscr subscr_spec.
Proof.
  start_function.
  apply semax_post'' with
     (EX p: val, EX q: val,
                       PROP ( )
                       LOCAL (temp ret_temp q)
                       SEP (subscr_post b t x p q)).
 reflexivity.
 {
  Intros p q; Exists p q.
  unfold subscr_post.
  destruct (tree_inb x t) eqn:?.
  apply tree_inb_true_iff in  Heqb0. entailer!.  apply orp_right1. auto.
  apply tree_inb_false_iff in  Heqb0. entailer!. apply orp_right2. entailer!.
 }
  rename H into Range_x.
  eapply semax_pre; [
    | apply (semax_loop _ (subscr_inv b t x) (subscr_inv b t x))].
  * (* Precondition *)
    unfold subscr_inv.
    Exists b t.
    entailer!.
    apply allp_right; intros p.
    apply allp_right; intros q.
    apply wand_sepcon_adjoint; entailer!.
  * (* Loop body *)
    unfold subscr_inv.
    Intros b1 t1.
    (* TODO: why this skip is here? *)
    forward. (* Sskip *)
    destruct t1; simpl treebox_rep at 1.
    + forward. (* p = *t; *)
      forward_if; [clear H | inversion H]. (* then clause *)
      forward_call (sizeof t_struct_tree).
      Intros p1.
      rewrite memory_block_data_at_ by auto.
      forward. (* p->key=x; *)
      simpl.
      forward. (* p->value=NULL; *)
      forward. (* p->left=NULL; *)
      forward. (* p->right=NULL; *)
      forward. (* *t = p; *)
      forward. (* return (&p->value); *)
      Exists p1 (offset_val 4 p1).
      rewrite (sepcon_comm (_ * _)); apply wand_sepcon_adjoint.
      apply (allp_left _ p1), (allp_left _ (offset_val 4 p1)).
      apply wand_sepcon_adjoint; rewrite <- (sepcon_comm (_ * _)).
      entailer!.
      apply modus_ponens_wand'.
      unfold subscr_post.
      simpl.
      replace (offset_val 4 p1)
        with (field_address t_struct_tree [StructField _value] p1)
        by (unfold field_address; simpl;
            rewrite if_true by auto with field_compatible; auto).
      simpl_compb. simpl_compb.
      unfold_data_at (data_at _ _ _ p1).
      rewrite (field_at_data_at _ t_struct_tree [StructField _value]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
      entailer!.
    +
      Intros.
      forward. (* p = *t; *)
      forward_if. (* else clause *)
       (* TODO: better automation for field_compatible. *)
        1: admit.
      (* TODO: better automation for field_compatible. *)
        1: admit.
      forward. (* y=p->key; *)
      forward_if; [ | forward_if ].
      - (* Inner if, then clause: x<k *)
        forward. (* t=&p->left *)
        unfold subscr_inv.
        Exists (offset_val 8 v) t1_1.
        entailer!.
        apply RAMIF_Q2_trans'.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 8 v)
          with (field_address t_struct_tree [StructField _left] v)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        entailer!.
        apply allp_right; intros p.
        apply allp_right; intros q.
        apply -> wand_sepcon_adjoint.
        unfold subscr_post.
        simpl.
        simpl_compb.
        simpl_compb.
        simpl.
        simpl_compb.
        entailer!.
      - (* Inner if, second branch:  k<x *)
        forward. (* t=&p->right *)
        unfold subscr_inv.
        Exists (offset_val 12 v) t1_2.
        entailer!.
        apply RAMIF_Q2_trans'.
        (* TODO: SIMPLY THIS LINE *)
        replace (offset_val 12 v)
          with (field_address t_struct_tree [StructField _right] v)
          by (unfold field_address; simpl;
              rewrite if_true by auto with field_compatible; auto).
        entailer!.
        apply allp_right; intros p.
        apply allp_right; intros q.
        apply -> wand_sepcon_adjoint.
        unfold subscr_post.
        simpl.
        simpl_compb.
        simpl_compb.
        simpl.
        simpl_compb.
        simpl_compb.
        simpl_compb.
        simpl_compb.
        entailer!.
      - (* Inner if, third branch: x=k *)
        assert (x=k) by lia.
        subst x. clear H1 H2.

        forward. (* return (&p->value) *)

        Exists v (offset_val 4 v).
        entailer!.
        rewrite (sepcon_comm (_ * _ * _ * _)); apply wand_sepcon_adjoint.
        apply (allp_left _ v), (allp_left _ (offset_val 4 v)).
        apply wand_sepcon_adjoint; rewrite <- (sepcon_comm (_ * _ * _ * _)).
        apply modus_ponens_wand'.
        unfold subscr_post.
        simpl.
        simpl_compb.
        simpl_compb.
        simpl_compb.
        simpl_compb.
        simpl.
        simpl_compb.
        simpl_compb.
        entailer!.
        unfold field_address; simpl.
        rewrite if_true; auto.
        rewrite field_compatible_cons in H3 |- *.
        simpl in H3 |- *.
        split.
        1: right; left; auto.
        tauto.
  * (* After the loop *)
    forward.
    simpl loop2_ret_assert. apply andp_left2. auto.
all:fail.
Admitted.
(*
Definition lookup_inv (b0 p0: val) (t0: tree val) (x: Z): environ -> mpred :=
  EX p: val, EX t: tree val,
  PROP(lookup nullval x t = lookup nullval x t0)
  LOCAL(temp _p p; temp _x (Vint (Int.repr x)))
  SEP(tree_rep t p;  (tree_rep t p -* tree_rep t0 p0)).

Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold treebox_rep. Intros p.
  forward. (* p=*t; *)
  apply (semax_post''
                      (PROP ( )
                       LOCAL (temp ret_temp (lookup nullval x t))
                       SEP (data_at Tsh (tptr t_struct_tree) p b; tree_rep t p))).
  1: unfold treebox_rep; Exists p.
     (* TODO: let entailer work here. *)
     apply derives_refl'. f_equal. f_equal.
     unfold SEPx; simpl. extensionality rho. symmetry; apply sepcon_assoc.
  apply semax_frame''.
  forward_while (lookup_inv b p t x).
  * (* precondition implies loop invariant *)
    Exists p t. entailer!.
    apply -> wand_sepcon_adjoint. cancel.
  * (* type-check loop condition *)
    entailer!.
  * (* loop body preserves invariant *)
    destruct t0; unfold tree_rep at 1; fold tree_rep. normalize.
    contradiction HRE; auto.
    Intros pa pb.
    forward.
    forward_if; [ | forward_if ].
    + (* then clause: x<y *)
      forward. (* p=p<-left *)
      Exists (pa,t0_1). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        Exists pa pb; entailer!.
    + (* else-then clause: y<x *)
      forward. (* p=p<-right *)
      Exists (pb,t0_2). unfold fst,snd.
      entailer!.
      - rewrite <- H0; simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply RAMIF_PLAIN.trans''.
        apply -> wand_sepcon_adjoint.
        Exists pa pb; entailer!.
    + (* else-else clause: x=y *)
      assert (x=k) by lia. subst x. clear H H4 H5.
      forward. (* v=p->value *)
      forward. (* return v; *)
      unfold treebox_rep. unfold normal_ret_assert.
      entailer!.
      - rewrite <- H0. simpl.
        simpl_compb; simpl_compb; auto.
      - (* TODO: merge the following 2 lines *)
        apply modus_ponens_wand'.
        Exists pa pb; entailer!.
  * (* after the loop *)
    forward. (* return NULL; *)
    entailer!.
    apply modus_ponens_wand.
Qed.
*)
(*
Lemma body_turn_left: semax_body Vprog Gprog f_turn_left turn_left_spec.
Proof.
  start_function.
  simpl.
  Intros pb pc.
  forward. (* mid=r->left *)
  forward. (* l->right=mid *)
  assert_PROP (is_pointer_or_null pb) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  forward. (* r->left=l *)
  assert_PROP (is_pointer_or_null l) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  forward. (* _l = r *)
  assert_PROP (is_pointer_or_null r) by entailer!.
  rewrite is_pointer_or_null_force_val_sem_cast_neutral by auto.
  Opaque tree_rep. forward. Transparent tree_rep. (* return *)
  (* TODO: simplify the following proof *)
  Exists pc.
  entailer!.
  simpl.
  Exists pa pb.
  entailer!.
Qed.

Definition pushdown_left_inv (b_res: val) (t_res: tree val): environ -> mpred :=
  EX b: val, EX ta: tree val, EX x: Z, EX v: val, EX tb: tree val,
  PROP  ()
  LOCAL (temp _t b)
  SEP   (treebox_rep (T ta x v tb) b;
         (treebox_rep (pushdown_left ta tb) b -* treebox_rep t_res b_res)).

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  eapply semax_pre; [
    | apply (semax_loop _ (pushdown_left_inv b (pushdown_left ta tb))
                         (pushdown_left_inv b (pushdown_left ta tb)))].
  + (* Precondition *)
    unfold pushdown_left_inv.
    Exists b ta x v tb.
    entailer!.
    eapply derives_trans; [| apply ramify_PPQQ].
    rewrite (treebox_rep_spec (T ta x v tb)).
    Exists p.
    entailer!.
  + (* Loop body *)
    unfold pushdown_left_inv.
    clear x v H H0.
    Intros b0 ta0 x vx tbc0.
    unfold treebox_rep at 1.
    Intros p0.
    forward. (* skip *)
    forward. (* p = *t; *)
      (* TODO: The following should be solve automatically. satuate local does not work *)
      1: rewrite (add_andp _ _ (tree_rep_saturate_local _ _)); entailer!.
    simpl tree_rep.
    Intros pa pbc.
    forward. (* q = p->right *)
    forward_if.
    - subst.
      assert_PROP (tbc0 = (@E _)).
        1: entailer!.
      subst.
      forward. (* q=p->left *)
      forward. (* *t=q *)
      forward_call (p0, sizeof t_struct_tree). (* freeN(p, sizeof ( *p )); *)
      {
        entailer!.
        rewrite memory_block_data_at_ by auto.
        cancel.
      }
      forward. (* return *)
      apply modus_ponens_wand'.
      Exists pa.
      cancel.
    - destruct tbc0 as [| tb0 y vy tc0].
        { simpl tree_rep. normalize. contradiction H1; auto. }
      forward_call (ta0, x, vx, tb0, y, vy, tc0, b0, p0, pa, pbc). (* turn_left(t, p, q); *)
      Intros pc.
      forward. (* t = &q->left; *)
      Exists (field_address t_struct_tree [StructField _left] pbc) ta0 x vx tb0.
      (* TODO: not to simply to much in entailer? *)
      Opaque tree_rep. entailer!. Transparent tree_rep.
        (* TODO: simplify this line *)
        1: unfold field_address; simpl; rewrite if_true by auto with field_compatible; auto.
      apply RAMIF_PLAIN.trans'.
      apply bst_left_entail; auto.
  + forward. (* Sskip *)
    (* TODO: entailer! does not work here. *)
    unfold loop2_ret_assert.
    apply andp_left2, derives_refl.
Qed.

Lemma body_treebox_new: semax_body Vprog Gprog f_treebox_new treebox_new_spec.
Proof.
  start_function.
  forward_call (sizeof (tptr t_struct_tree)).
  simpl sizeof; computable.
  Intros p.
  rewrite memory_block_data_at_ by auto.
  forward.
  forward.
  Exists p. entailer!.
Qed.

Lemma body_tree_free: semax_body Vprog Gprog f_tree_free tree_free_spec.
Proof.
  start_function.
  forward_if (PROP()LOCAL()SEP()).
  + destruct t; simpl tree_rep.
      1: Intros. contradiction.
    Intros pa pb.
    forward.
    forward.
    forward_call (p, sizeof t_struct_tree).
    {
      entailer!.
      rewrite memory_block_data_at_ by auto.
      cancel.
    }
    forward_call (t1,pa).
    forward_call (t2,pb).
    entailer!.
  + forward.
    subst.
    entailer!.
    simpl; normalize.
  + forward.
Qed.

Lemma body_treebox_free: semax_body Vprog Gprog f_treebox_free treebox_free_spec.
Proof.
  start_function.
  unfold treebox_rep.
  Intros p.
  forward.
  forward_call (t,p).
  forward_call (b, sizeof (tptr t_struct_tree)).
  entailer!.
  rewrite memory_block_data_at_ by auto.
  cancel.
  forward.
Qed.

*)


(* * ZF set theory with Skolem function symbols *)
(* ** Axiomatisations *)

Require Export Undecidability.FOL.Utils.FullSyntax.
Require Export Undecidability.FOL.Sets.Signatures.
Import Vector.VectorNotations.
Require Import List.

Declare Scope syn.
Open Scope syn.

(* ** Signature for ZF axiomatisation, containing function symbols for set operations *)

Import ZFSignature.
Export ZFSignature.

(* ** Axioms *)

Notation "x ∈ y" := (atom _ ZF_pred_sig elem ([x; y])) (at level 35) : syn.
Notation "x ≡ y" := (atom (Σ_preds := ZF_pred_sig) equal ([x; y])) (at level 35) : syn.

Notation "∅" := (func ZF_func_sig eset ([])) : syn.
Notation "'ω'" := (func ZF_func_sig om ([])) : syn.
Notation "{ x ; y }" := (func ZF_func_sig pair ([x; y])) (at level 31) : syn.
Notation "⋃ x" := (func ZF_func_sig union ([x])) (at level 32) : syn.
Notation "'PP' x" := (func ZF_func_sig power ([x])) (at level 31) : syn.
Notation "x ∪ y" := (⋃ {x; y}) (at level 32) : syn.
Notation  "'σ' x" := (x ∪ {x; x}) (at level 32) : syn.

Definition sub x y :=
  ∀ $0 ∈ x`[↑] → $0 ∈ y`[↑].

Notation "x ⊆ y" := (sub x y) (at level 34) : syn.

Definition ax_ext :=
  ∀ ∀ $1 ⊆ $0 → $0 ⊆ $1 → $1 ≡ $0.

Definition ax_eset :=
  ∀ ¬ ($0 ∈ ∅).

Definition ax_pair :=
  ∀ ∀ ∀ $0 ∈ {$1; $2} ↔ $0 ≡ $1 ∨ $0 ≡ $2.

Definition ax_union :=
  ∀ ∀ $0 ∈ ⋃ $1 ↔ ∃ $0 ∈ $2 ∧ $1 ∈ $0.

Definition ax_power :=
  ∀ ∀ $0 ∈ PP $1 ↔ $0 ⊆ $1.

Definition inductive x :=
  ∅ ∈ x ∧ ∀ $0 ∈ x`[↑] → σ $0 ∈ x`[↑].

Definition ax_om1 :=
  inductive ω.

Definition ax_om2 :=
  ∀ inductive $0 → ω ⊆ $0.

Definition ax_sep phi :=
  ∀ ∃ ∀ $0 ∈ $1 ↔ $0 ∈ $2 ∧ phi[$0.: Nat.add 3 >> var].

Definition fun_rel phi :=
  ∀ ∀ ∀ phi[$2 .: $1 .: Nat.add 3 >> var] → phi[$2 .: $0 .: Nat.add 3 >> var] → $1 ≡ $0.

Definition ax_rep phi :=
  fun_rel phi → ∀ ∃ ∀ $0 ∈ $1 ↔ ∃ $0 ∈ $3 ∧ phi[$0 .: $1 .: Nat.add 4 >> var].

(* Hereditarily finite set theory *)

Definition HF :=
  ax_ext :: ax_eset :: ax_pair :: ax_union :: ax_power :: nil.

Definition ax_no_inductive :=
  ∀ ¬ inductive $0.

Definition HFN :=
  ax_no_inductive :: HF.

(* List of core axioms without schemes for separation and replacement *)

Definition ZF' :=
  ax_ext :: ax_eset :: ax_pair :: ax_union :: ax_power :: ax_om1 :: ax_om2 :: nil.

(* Theory of Z including the separation scheme *)

Inductive Z : form -> Prop :=
| Z_base phi : In phi ZF' -> Z phi
| Z_sep phi : Z (ax_sep phi).

(* Theory of full ZF including the separation and replacement schemes *)

Inductive ZF : form -> Prop :=
| ZF_base phi : In phi ZF' -> ZF phi
| ZF_sep phi : ZF (ax_sep phi)
| ZF_rep phi : ZF (ax_rep phi).

Definition ax_refl :=
  ∀ $0 ≡ $0.

Definition ax_sym :=
  ∀ ∀ $1 ≡ $0 → $0 ≡ $1.

Definition ax_trans :=
  ∀ ∀ ∀ $2 ≡ $1 → $1 ≡ $0 → $2 ≡ $0.

Definition ax_eq_elem :=
  ∀ ∀ ∀ ∀ $3 ≡ $1 → $2 ≡ $0 → $3 ∈ $2 → $1 ∈ $0.

(* List of HF axioms plus equality axioms *)

Definition HFeq :=
  ax_refl :: ax_sym :: ax_trans :: ax_eq_elem :: HF.

Definition HFNeq :=
  ax_refl :: ax_sym :: ax_trans :: ax_eq_elem :: HFN.

(* List of core axioms plus equality axioms *)

Definition ZFeq' :=
  ax_refl :: ax_sym :: ax_trans :: ax_eq_elem :: ZF'.

(* Theory of Z plus equality axioms *)

Inductive Zeq : form -> Prop :=
| Zeq_base phi : In phi ZFeq' -> Zeq phi
| Zeq_sep phi : Zeq (ax_sep phi).

(* Theory of full ZF plus equality axioms *)

Inductive ZFeq : form -> Prop :=
| ZFeq_base phi : In phi ZFeq' -> ZFeq phi
| ZFeq_sep phi : ZFeq (ax_sep phi)
| ZFeq_rep phi : ZFeq (ax_rep phi).


From Coq Require Import List.
From Comparse Require Import Monad Combinators.
From MiniHTTPServerFFI Require Import Slice SliceFacts.
From CoqFFI Require Import String.
From ExtLib Require Import Char Monad.

Open Scope string_scope.
Import MonadLetNotation.
Import ApplicativeNotation.
Import ListNotations.

Inductive directory_id : Type :=
| Dirname (s : Slice.t)
| Current
| Parent.

Inductive uri := make_uri { dirname : list directory_id
                          ; filename : Slice.t
                          }.

#[local]
Fixpoint canonicalize_aux (acc : list directory_id) (dirids : list directory_id)
  : list directory_id :=
  match dirids with
  | Current :: rst => canonicalize_aux acc rst
  | Parent :: rst => canonicalize_aux (tl acc) rst
  | x :: rst => canonicalize_aux (x :: acc) rst
  | [] => rev acc
  end.

Definition canonicalize := canonicalize_aux [].

Definition dirname_eq (d1 d2: list directory_id) : Prop :=
  canonicalize d1 = canonicalize d2.

Inductive canonical : list directory_id -> Prop :=
| canonical_nil : canonical []
| canonical_cons
    (s : Slice.t) (rst : list directory_id) (canonical_rst : canonical rst)
  : canonical (Dirname s :: rst).

Lemma canonical_canonical_tl (d : list directory_id)
  : canonical d -> canonical (tl d).

Proof.
  intros canon.
  destruct d as [ | x rst].
  + auto.
  + now inversion canon.
Qed.

Lemma canonical_canonical_cons (a : directory_id) (d : list directory_id)
  : canonical (a :: d) <-> canonical [a] /\ canonical d.

Proof.
  split.
  + intros canon; inversion canon; subst.
    split; repeat constructor.
    exact canonical_rst.
  + intros [c1 c2].
    inversion c1; subst.
    constructor; auto.
Qed.

Lemma canonical_canonical_app (d1 d2 : list directory_id)
  : canonical d1 /\ canonical d2 <-> canonical (d1 ++ d2).

Proof.
  revert d2.
  induction d1; intros d2.
  + cbn.
    split.
    ++ now intros [_ exact].
    ++ intros exact; split; [ constructor | auto ].
  + cbn.
    rewrite (canonical_canonical_cons a d1).
    rewrite (canonical_canonical_cons a (d1 ++ d2)).
    rewrite <- IHd1.
    now rewrite and_assoc.
Qed.

Lemma canonical_canonical_rev (d : list directory_id)
  : canonical d <-> canonical (rev d).

Proof.
  induction d.
  + reflexivity.
  + cbn.
    rewrite canonical_canonical_cons.
    rewrite <- (canonical_canonical_app (rev d) [a]).
    now rewrite IHd.
Qed.

#[local]
Lemma canonicalize_aux_canonical (d acc : list directory_id)
    (acc_canon : canonical acc)
  : canonical (canonicalize_aux acc d).

Proof.
  revert acc acc_canon.
  induction d; intros acc acc_canon.
  + cbn.
    now rewrite <- canonical_canonical_rev.
  + destruct a.
    ++ cbn.
       apply IHd.
       constructor; auto.
    ++ cbn.
       now apply IHd.
    ++ cbn.
       apply IHd.
       now apply canonical_canonical_tl.
Qed.

Lemma canonicalize_canonical (d : list directory_id)
  : canonical (canonicalize d).

Proof.
  apply canonicalize_aux_canonical.
  constructor.
Qed.

#[local]
Remark canonical_canonicalize_aux_cons_equ
    (d : list directory_id) (canon : canonical d) (acc : list directory_id)
  : canonicalize_aux acc d = List.app (rev acc) (canonicalize_aux nil d).

Proof.
  revert acc.
  induction d.
  + intros acc.
    now rewrite <- app_nil_end.
  + intros acc.
    cbn.
    inversion canon; subst.
    rewrite IHd; auto.
    cbn.
    rewrite <- app_assoc.
    now erewrite (IHd canonical_rst [Dirname s]).
Qed.

Remark canonical_canonicalize_cons_equ (s : Slice.t)
    (d : list directory_id) (canon : canonical d)
  : canonicalize (Dirname s :: d) = Dirname s :: canonicalize d.

Proof.
  unfold canonicalize.
  cbn.
  now rewrite canonical_canonicalize_aux_cons_equ.
Qed.

Lemma canonicalize_canonical_equ (d : list directory_id) (canon : canonical d)
  : canonicalize d = d.

Proof.
  induction d.
  + auto.
  + inversion canon; subst.
    rewrite canonical_canonicalize_cons_equ; auto.
    rewrite IHd; auto.
Qed.

Lemma canonicalize_idempontent (d : list directory_id)
  : canonicalize (canonicalize d) = canonicalize d.

Proof.
  rewrite canonicalize_canonical_equ; [ reflexivity | ].
  apply canonicalize_canonical.
Qed.

#[program, local]
Fixpoint uri_to_path_aux (d : list directory_id) (canon : canonical d) : string :=
  match d with
  | [] => ""
  | Dirname x :: rst => (Slice.to_string x) ++ "/" ++ uri_to_path_aux rst _
  | Parent :: _ => _
  | Current :: _ => _
  end.

Next Obligation.
  inversion canon; auto.
Defined.

Next Obligation.
  exfalso; inversion canon.
Defined.

Next Obligation.
  exfalso; inversion canon.
Defined.

#[program]
Definition uri_to_path (u : uri) : string :=
  "/" ++ uri_to_path_aux (canonicalize (dirname u)) _ ++ Slice.to_string (filename u).

Next Obligation.
  apply canonicalize_canonical.
Qed.

Definition sandbox (base : list directory_id) (req : uri) : uri :=
  make_uri (List.app base (canonicalize (dirname req))) (filename req).

(** * Parsing URI *)

Definition char (c : ascii) : parser Slice.t ascii := token c.
Definition str (t : string) : parser Slice.t unit := tag (t := ascii) (Slice.of_string t).

#[global] Axiom str_Parser : forall x rst, Parser slice_length (str (String x rst)).
#[global] Axiom str_StrictParser : forall x rst, StrictParser slice_length (str (String x rst)).

Existing Instance str_Parser.
Existing Instance str_StrictParser.

Definition dir_id_sep : parser Slice.t unit :=
  eoi <|> skip (char "/") <|> skip (char " ").

Definition uri_char : parser Slice.t ascii :=
  ensure read_token (fun x => negb ((eqb x " ") || (eqb x "/"))).

Definition dirid : parser Slice.t directory_id :=
  many (char "/");;
  (let* name := some_until uri_char (peek dir_id_sep) in
   peek (char "/");;
   pure (Dirname (Slice.pack name)))
  <|> (str "..";;
       peek dir_id_sep;;
       pure Parent)
  <|> (char ".";;
       peek dir_id_sep;;
       pure Current).

Definition path_dirname : parser Slice.t (list directory_id) := many dirid.

Definition path_filename : parser Slice.t Slice.t :=
  let* candidat := many uri_char in
  match candidat with
  | [] => pure (Slice.of_string "index.html")
  | x => pure (Slice.pack x)
  end.

Definition read_uri : parser Slice.t uri :=
  let* dir := path_dirname in
  many (char "/");;
  let* file := path_filename in
  pure (make_uri dir file).


(** * Total Categories and Total Functors *)

Require Import UniMath.Foundations.Sets.

(* Needed for pr1_issurjective *)
Require Import UniMath.MoreFoundations.AxiomOfChoice.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.

Local Open Scope cat.
Local Open Scope mor_disp.

(** ** Definition and forgetful functor *)

(* Any displayed category has a total category, with a forgetful functor to the base category. *)
Section Total_Category.

  Section Total_Category_data.

    Context {C : precategory_data} (D : disp_cat_data C).

    Definition total_category_ob_mor : precategory_ob_mor.
    Proof.
      exists (∑ x:C, D x).
      intros xx yy.
      (* note: we use projections rather than destructing, so that [ xx --> yy ]
         can β-reduce without [xx] and [yy] needing to be in whnf *)
      exact (∑ (f : pr1 xx --> pr1 yy), pr2 xx -->[f] pr2 yy).
    Defined.

    Definition total_category_id_comp : precategory_id_comp (total_category_ob_mor).
    Proof.
      apply tpair; simpl.
      - intros. exists (identity _). apply id_disp.
      - intros xx yy zz ff gg.
        exists (pr1 ff · pr1 gg).
        exact (pr2 ff ;; pr2 gg).
    Defined.

    Definition total_category_data : precategory_data
      := (total_category_ob_mor ,, total_category_id_comp).

  End Total_Category_data.

  (* TODO: make notations [( ,, )] and [ ;; ] different levels?  ;; should bind tighter, perhaps, and ,, looser? *)
  Lemma total_category_is_precat {C : category} (D : disp_cat C) :
    is_precategory (total_category_data D).
  Proof.
    apply is_precategory_one_assoc_to_two.
    repeat apply tpair; simpl.
    - intros xx yy ff; cbn.
      use total2_paths_f; simpl.
      apply id_left.
      eapply pathscomp0.
      apply maponpaths, id_left_disp.
      apply transportfbinv.
    - intros xx yy ff; cbn.
      use total2_paths_f; simpl.
      apply id_right.
      eapply pathscomp0.
      apply maponpaths, id_right_disp.
      apply transportfbinv.
    - intros xx yy zz ww ff gg hh.
      use total2_paths_f; simpl.
      apply assoc.
      eapply pathscomp0.
      apply maponpaths, assoc_disp.
      apply transportfbinv.
  Qed.

  (* The “pre-category” version, without homsets *)
  Definition total_precategory {C : category} (D : disp_cat C) : precategory :=
    (total_category_data D ,, total_category_is_precat D).

  Lemma total_category_has_homsets {C : category} (D : disp_cat C) :
    has_homsets (total_category_data D).
  Proof.
    intros ? ?; simpl. apply isaset_total2. apply homset_property.
    intros; apply homsets_disp.
  Qed.

  Definition total_category {C : category} (D : disp_cat C) : category :=
    (total_precategory D,, total_category_has_homsets D).

  Definition pr1_category_data {C : category} (D : disp_cat C) :
    functor_data (total_category D) C.
  Proof.
    exists pr1.
    intros a b; exact pr1.
  Defined.

  Lemma pr1_category_is_functor {C : category} (D : disp_cat C) :
    is_functor (pr1_category_data D).
  Proof.
    apply tpair.
    - intros x; apply idpath.
    - intros x y z f g; apply idpath.
  Qed.

  Definition pr1_category {C : category} (D : disp_cat C) :
    functor (total_category D) C :=
    make_functor (pr1_category_data D) (pr1_category_is_functor D).

  Lemma full_pr1_category {C : category} (D : disp_cat C)
        (H : ∏ (a b : total_category D) (x : C ⟦ pr1 a, pr1 b ⟧), (∥ pr2 a -->[ x] pr2 b ∥))
    : full (pr1_category D).
  Proof.
    intros ? ?.
    use pr1_issurjective.
    apply H.
  Defined.

  Lemma faithful_pr1_category {C : category} (D : disp_cat C)
        (H : ∏ (a b : total_precategory D) (x : C ⟦ pr1 a, pr1 b ⟧), isaprop (pr2 a -->[ x] pr2 b))
    : faithful (pr1_category D).
  Proof.
    intros ? ?.
    apply isinclpr1, H.
  Defined.

  Definition fully_faithful_pr1_category {C : category} (D : disp_cat C)
             (H : ∏ (a b : total_precategory D) (x : C ⟦ pr1 a, pr1 b ⟧), iscontr (pr2 a -->[ x] pr2 b))
    : fully_faithful (pr1_category D).
  Proof.
    intros ? ?.
    apply isweqpr1, H.
  Defined.

  (** ** Isomorphisms and saturation *)

  Definition is_z_iso_total {C : category} {D : disp_cat C}
             {xx yy : total_category D} (ff : xx --> yy)
             (i : is_z_isomorphism (pr1 ff))
             (fi := pr1 ff,, i)
             (ii : is_z_iso_disp fi (pr2 ff))
    : is_z_isomorphism ff.
  Proof.
    exists (inv_from_z_iso fi,, pr1 ii).
    split.
    - use total2_paths_f.
      apply (z_iso_inv_after_z_iso fi).
      etrans. apply maponpaths. apply (inv_mor_after_z_iso_disp ii).
      apply transportfbinv.
    - use total2_paths_f.
      apply (z_iso_after_z_iso_inv fi).
      etrans. apply maponpaths. apply (z_iso_disp_after_inv_mor ii).
      apply transportfbinv.
  Qed.

  Definition inv_from_z_iso_in_total
             {C : category}
             {D : disp_cat C}
             {x y : C}
             {f : x --> y}
             (Hf : is_z_isomorphism f)
             {xx : D x}
             {yy : D y}
             {ff : xx -->[ f ] yy}
             (Hff : is_z_iso_disp (f ,, Hf) ff)
    : pr1 (inv_from_z_iso
             (make_z_iso' _
                (@is_z_iso_total
                   C D
                   (x ,, xx) (y ,, yy)
                   (f ,, ff)
                   Hf
                   Hff)))
      =
        inv_from_z_iso (_,,Hf).
  Proof.
    apply inv_z_iso_unique'.
    unfold precomp_with ; cbn.
    exact (maponpaths
             pr1
             (z_iso_inv_after_z_iso
                (make_z_iso'
                   _
                   (@is_z_iso_total
                      C D
                      (x ,, xx) (y ,, yy)
                      (f ,, ff)
                      Hf
                      Hff)))).
  Qed.

  Definition is_z_iso_base_from_total {C : category} {D : disp_cat C}
             {xx yy : total_category D} {ff : xx --> yy} (i : is_z_isomorphism ff)
    : is_z_isomorphism (pr1 ff).
  Proof.
    set (ffi := ff ,, i).
    exists (pr1 (inv_from_z_iso ffi)).
    split.
    - exact (maponpaths pr1 (z_iso_inv_after_z_iso ffi)).
    - exact (maponpaths pr1 (z_iso_after_z_iso_inv ffi)).
  Qed.

  Definition z_iso_base_from_total {C : category} {D : disp_cat C}
             {xx yy : total_category D} (ffi : z_iso xx yy) : z_iso (pr1 xx) (pr1 yy) :=
    _ ,, (is_z_iso_base_from_total (pr2 ffi)).

  Definition inv_z_iso_base_from_total {C : category} {D : disp_cat C}
             {xx yy : total_precategory D} (ffi : z_iso xx yy) :
    inv_from_z_iso (z_iso_base_from_total ffi) = pr1 (inv_from_z_iso ffi).
  Proof.
    apply pathsinv0, inv_z_iso_unique'. unfold precomp_with.
    exact (maponpaths pr1 (z_iso_inv_after_z_iso ffi)).
  Qed.

  Definition is_z_iso_disp_from_total {C : category} {D : disp_cat C}
             {xx yy : total_precategory D} {ff : xx --> yy} (i : is_z_isomorphism ff) (ffi := ff ,, i) :
    is_z_iso_disp (z_iso_base_from_total (ff,,i)) (pr2 ff).
  Proof.
    use tpair; [ | split].
    - eapply transportb. apply inv_z_iso_base_from_total.
      exact (pr2 (inv_from_z_iso ffi)).
    - etrans. apply mor_disp_transportf_postwhisker.
      etrans. apply maponpaths, @pathsinv0.
      exact (fiber_paths (!z_iso_after_z_iso_inv ffi)).
      etrans. apply transport_f_f.
      use (toforallpaths _ _ _ _ (id_disp _)).
      unfold transportb; apply maponpaths, homset_property.
    - etrans. apply mor_disp_transportf_prewhisker.
      etrans. apply maponpaths, @pathsinv0.
      exact (fiber_paths (!z_iso_inv_after_z_iso ffi)).
      etrans. apply transport_f_f.
      use (toforallpaths _ _ _ _ (id_disp _)).
      unfold transportb; apply maponpaths, homset_property.
  Qed.

  Definition z_iso_disp_from_total {C : category} {D : disp_cat C}
             {xx yy : total_precategory D} (ff : z_iso xx yy) :
    z_iso_disp (z_iso_base_from_total ff) (pr2 xx) (pr2 yy).
  Proof.
    exact (_,, is_z_iso_disp_from_total (pr2 ff)).
  Defined.

  Definition total_z_iso {C : category} {D : disp_cat C} {xx yy : total_category D}
             (f : z_iso (pr1 xx) (pr1 yy)) (ff : z_iso_disp f (pr2 xx) (pr2 yy))
    : z_iso xx yy.
  Proof.
    exists (pr1 f,, pr1 ff).
    apply (is_z_iso_total (pr1 f,, pr1 ff) (pr2 f) (pr2 ff)).
  Defined.

  Lemma inv_mor_total_z_iso {C : category} {D : disp_cat C} {xx yy : total_category D}
        (f : z_iso (pr1 xx) (pr1 yy)) (ff : z_iso_disp f (pr2 xx) (pr2 yy))
    : inv_from_z_iso (total_z_iso f ff)
      = (inv_from_z_iso f,, inv_mor_disp_from_z_iso ff).
  Proof.
    (* Could de-opacify [is_z_iso_total] and then use [inv_from_z_iso_].  If de-opacfying [is_z_iso_total] would make its inverse compute definitionally, that’d be wonderful, but for the sake of just this one lemma, it’s probably not worth it.  So we prove this the hard way. *)
    apply cancel_precomposition_z_iso with (total_z_iso f ff).
    etrans. apply z_iso_inv_after_z_iso. apply pathsinv0.
    use total2_paths_f; cbn.
    - apply z_iso_inv_after_z_iso.
    - etrans. apply maponpaths, inv_mor_after_z_iso_disp.
      apply transportfbinv.
  Qed.

  Definition total_z_iso_equiv_map {C : category} {D : disp_cat C} {xx yy : total_category D}
    : (∑ f : z_iso (pr1 xx) (pr1 yy), z_iso_disp f (pr2 xx) (pr2 yy))
      -> z_iso xx yy
    := λ ff, total_z_iso (pr1 ff) (pr2 ff).

  Definition total_isweq_z_iso {C : category} {D : disp_cat C} (xx yy : total_category D)
    : isweq (@total_z_iso_equiv_map _ _ xx yy).
  Proof.
    use isweq_iso.
    - intros ff. exists (z_iso_base_from_total ff). apply z_iso_disp_from_total.
    - intros [f ff]. use total2_paths_f.
      + apply z_iso_eq, idpath.
      + apply eq_z_iso_disp.
        etrans. apply transportf_z_iso_disp.
        simpl pr2. simpl (pr1 (z_iso_disp_from_total _)).
        use (@maponpaths_2 _ _ _ (transportf _) _ (idpath _)).
        apply homset_property.
    - intros f. apply z_iso_eq; simpl.
      destruct f as [[f ff] w]; apply idpath.
  Qed.

  Definition total_z_iso_equiv {C : category} {D : disp_cat C} (xx yy : total_category D)
    : (∑ f : z_iso (pr1 xx) (pr1 yy), z_iso_disp f (pr2 xx) (pr2 yy))
        ≃ z_iso xx yy
    := make_weq _ (total_isweq_z_iso xx yy).

  Lemma is_univalent_total_category {C : category} {D : disp_cat C}
        (CC : is_univalent C) (DD : is_univalent_disp D) :
    is_univalent (total_category D).
  Proof.
    intros xs ys.
    set (x := pr1 xs). set (xx := pr2 xs).
    set (y := pr1 ys). set (yy := pr2 ys).
    use weqhomot.
    apply (@weqcomp _ (∑ e : x = y, transportf _ e xx = yy) _).
    apply total2_paths_equiv.
    apply (@weqcomp _ (∑ e : x = y, z_iso_disp (idtoiso e) xx yy) _).
    apply weqfibtototal.
    intros e. exists (λ ee, idtoiso_disp e ee).
    apply DD.
    apply (@weqcomp _ (∑ f : z_iso x y, z_iso_disp f xx yy) _).
    use (weqfp (make_weq _ _)). apply CC.
    apply total_z_iso_equiv.
    intros e; destruct e; apply z_iso_eq; cbn.
    apply idpath.
  Qed.

End Total_Category.

Arguments pr1_category [C] D.

Section TotalUnivalent.
  Definition total_univalent_category
             {C : univalent_category}
             (D : disp_univalent_category C)
    : univalent_category.
  Proof.
    use make_univalent_category.
    - exact (total_category D).
    - exact (is_univalent_total_category (pr2 C) (pr2 D)).
  Defined.
End TotalUnivalent.

(** ** Total functors of displayed functors*)
Section Total_Functors.

  Definition total_functor_data {C' C} {F}
             {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D)
    : functor_data (total_category D') (total_category D).
  Proof.
    use make_functor_data.
    - intros xx. exists (F (pr1 xx)). exact (FF _ (pr2 xx)).
    - intros xx yy ff. exists (# F (pr1 ff))%cat. exact (♯ FF (pr2 ff)).
  Defined.

  Definition total_functor_axioms {C' C} {F}
             {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D)
    : is_functor (total_functor_data FF).
  Proof.
    split.
    - intros xx; use total2_paths_f.
      apply functor_id.
      etrans. apply maponpaths, disp_functor_id.
      apply transportfbinv.
    - intros xx yy zz ff gg; use total2_paths_f; simpl.
      apply functor_comp.
      etrans. apply maponpaths, disp_functor_comp.
      apply transportfbinv.
  Qed.

  Definition total_functor {C' C} {F}
             {D' : disp_cat C'} {D : disp_cat C} (FF : disp_functor F D' D)
    : functor (total_category D') (total_category D)
    := (total_functor_data FF,, total_functor_axioms FF).

  (** Laws for total fucntors *)
  Definition total_functor_commute
             {C₁ C₂ : category}
             {F : C₁ ⟶ C₂}
             {D₁ : disp_cat C₁}
             {D₂ : disp_cat C₂}
             (FF : disp_functor F D₁ D₂)
    : pr1_category D₁ ∙ F ⟹ total_functor FF ∙ pr1_category D₂.
  Proof.
    use make_nat_trans.
    - exact (λ _, identity _).
    - abstract
        (intros ? ? ? ;
         cbn ;
         rewrite id_left, id_right ;
         apply idpath).
  Defined.

  Definition total_functor_commute_z_iso
             {C₁ C₂ : category}
             {F : C₁ ⟶ C₂}
             {D₁ : disp_cat C₁}
             {D₂ : disp_cat C₂}
             (FF : disp_functor F D₁ D₂)
    : nat_z_iso
        (pr1_category D₁ ∙ F)
        (total_functor FF ∙ pr1_category D₂).
  Proof.
    use make_nat_z_iso.
    * exact (total_functor_commute FF).
    * intro.
      apply identity_is_z_iso.
  Defined.

  Definition total_functor_identity
             {C : category}
             (D : disp_cat C)
    : functor_identity (total_category D)
                       ⟹
                       total_functor (disp_functor_identity D).
  Proof.
    use make_nat_trans.
    - exact (λ _, identity _).
    - abstract
        (intros ? ? ? ; simpl ;
         refine (@id_right (total_category _) _ _ _ @ _) ;
         exact (!(@id_left (total_category _) _ _ _))).
  Defined.

  Definition total_functor_comp
             {C₁ C₂ C₃ : category}
             {F : C₁ ⟶ C₂}
             {G : C₂ ⟶ C₃}
             {D₁ : disp_cat C₁}
             {D₂ : disp_cat C₂}
             {D₃ : disp_cat C₃}
             (FF : disp_functor F D₁ D₂)
             (GG : disp_functor G D₂ D₃)
    : total_functor FF ∙ total_functor GG
                    ⟹
                    total_functor (disp_functor_composite FF GG).
  Proof.
    use make_nat_trans.
    - exact (λ _, identity _).
    - abstract
        (intros x y f ;
         refine (@id_right (total_category _) _ _ _ @ _) ;
         exact (!(@id_left (total_category _) _ _ _))).
  Defined.

End Total_Functors.

Section Total_Nat_Trans.
  (** Total natural transformation *)
  Definition total_nat_trans
             {C₁ C₂ : category}
             {F G : C₁ ⟶ C₂}
             {τ : F ⟹ G}
             {D₁ : disp_cat C₁}
             {D₂ : disp_cat C₂}
             {FF : disp_functor F D₁ D₂}
             {GG : disp_functor G D₁ D₂}
             (ττ : disp_nat_trans τ FF GG)
    : nat_trans (total_functor FF) (total_functor GG).
  Proof.
    use make_nat_trans.
    - exact (λ x, τ (pr1 x) ,, ττ (pr1 x) (pr2 x)).
    - abstract
        (intros x y f ; cbn ;
         use total2_paths_b ;
         [ exact (nat_trans_ax τ _ _ (pr1 f))
         | exact (disp_nat_trans_ax ττ (pr2 f))]).
  Defined.

End Total_Nat_Trans.


Require Import BenB.

(* Correctheidsstelling in propositielogica. *)

(* Hier eerst het domeinmodel van de originele bedradingspagina. *)

(* Apparaat: cd-speler. *)
(* Auteur: Hanno Wupper. *)
Variable cdsp_stroom : Prop.
  (* Er staat 230 volt op de stekker van de cd-speler. *)
Variable cdsp_cd : Prop.
  (* Er draait een audio-cd in de cd-speler. *)
Variable cdsp_lol : Prop.
  (* Er staat een analoog geluidssignaal L op de linker line-uitgang van de cd-speler. *)
Variable cdsp_lor : Prop.
  (* Er staat een analoog geluidssignaal R op de rechter line-uitgang van de cd-speler. *)
Variable cdsp_aan : Prop.
  (* De aan-uit-knop van de cd-speler staat op 'aan'. *)
Definition cdsp :=
      cdsp_stroom
    /\
      cdsp_cd
    /\
      cdsp_aan
  ->
      cdsp_lol
    /\
      cdsp_lor
.
  (* Als er op de stekker van de cd-speler 230 volt staat, er een audio-cd in de cd-speler
     draait en de aan-uit-knop op 'aan' staat, dan staan er analoge geluidssignalen op
     de linker line-uitgang van de cd-speler en op de rechter line-uitgang van de cd-speler.
  *)

(* Apparaat: box-links. *)
(* Auteur: Hanno Wupper. *)
Variable boxl_in_l : Prop.
  (* Er staat een versterkt analoog monogeluidssignaal L op de ingang van box-links. *)
Variable mono_l : Prop.
  (* Er is monogeluid L in de kamer. *)
Definition boxl :=
    boxl_in_l
  ->
    mono_l
.
  (* Als er een versterkt analoog monogeluidssignaal L op de ingang van de box-links staat,
     dan is er monogeluid L te horen in de kamer.
  *)

(* Apparaat: versterker. *)
(* Auteur: Paul van Poecke. *)
Variable verst_linel : Prop.
  (* Er staat analoog geluidssignaal L op de linker line-ingang van de versterker. *)
Variable verst_liner : Prop.
  (* Er staat analoog geluidssignaal R op de rechter line-ingang van de versterker. *)
Variable verst_stroom : Prop.
  (* Er staat 230 volt op de stekker van de versterker. *)
Variable verst_sol : Prop.
  (* Er staat versterkt analoog geluidssignaal L op de linker speaker-uitgang van de versterker. *)
Variable verst_sor : Prop.
  (* Er staat versterkt analoog geluidssignaal R op de rechter speaker-uitgang van de versterker. *)
Variable verst_aan : Prop.
  (* De aan-uit-knop van de versterker staat op 'aan'. *)
Definition verst :=
    verst_stroom
  /\
    verst_linel
  /\
     verst_liner
  /\
     verst_aan
->
    verst_sol
  /\
    verst_sor.
  (* Als bij deze versterker er op de stekker 230 V staat,
     de aan/uit knop op 'aan' staat en op zowel de linker als
     de rechts line-ingangen een analoog geluidssignaal binnenkomt,
     dan staat een versterkt analoog geluidssignaal L op de speaker-uitgang L
     en versterkt analoog geluidssignaal R op de speaker-uitgang R.
  *)

(* Apparaat: stekkerdoos. *)
(* Auteur: Sebastiaan Versteeg. *)
Variable sd_stroom : Prop.
  (* Er staat 220/230 volt op de stekker van de stekkerdoos. *)
Variable sd_uit1 : Prop.
  (* Er staat 220/230 volt op uitgang 1 van de stekkerdoos waarop andere apparaten
     kunnen worden aangesloten waardoor het aangesloten apparaat ook 220/230 volt
     krijgt.
  *)
Variable sd_uit2 : Prop.
  (* Er staat 220/230 volt op uitgang 2 van de stekkerdoos waarop andere apparaten
     kunnen worden aangesloten waardoor het aangesloten apparaat ook 220/230 volt
     krijgt.
  *)
Variable sd_uit3 : Prop.
  (* Er staat 220/230 volt op uitgang 3 van de stekkerdoos waarop andere apparaten
     kunnen worden aangesloten waardoor het aangesloten apparaat ook 220/230 volt
     krijgt.
  *)
Definition sd :=
    sd_stroom
  ->
      sd_uit1
    /\
      sd_uit2
    /\
      sd_uit3
.
  (* Als de stekkerdoos stroom krijgt,
     dan krijgen de apparaten die zijn aangesloten ook stroom. *)

(* Apparaat: waterkoker. *)
(* Auteurs: Michel Kok en Bram in 't Zandt. *)
Variable wk_stroom : Prop.
  (* Er staat 230 volt op de stekker van de waterkoker. *)
Variable wk_knop : Prop.
  (* De knop op de waterkoker is ingedrukt. *)
Variable wk_verwarmen : Prop.
  (* Het water in de waterkoker wordt verwarmd. *)
Variable wk_temperatuur : Prop.
  (* Het water in de waterkoker is op de gewenste temperatuur. *)
Definition wk :=
      wk_stroom
    /\
      wk_knop
  ->
      wk_verwarmen
    <->
      ~ wk_temperatuur
.
  (* Als deze waterkoker 230 volt krijgt en de knop is ingedrukt,
     dan wordt het water verwarmd. *)

(* Apparaat: bewegingssensor. *)
(* Auteur: Thomas Churchman. *)
Variable bws_stroom_in : Prop.
  (* Spanning op de input-stekker van de bewegingssensor. *)
Variable bws_stroom_uit : Prop.
  (* Spanning op de output-stekker van de bewegingssensor. *)
Variable bws_detectie : Prop.
  (* Beweging gedetecteerd in de afgelopen twee minuten. *)
Definition bws :=
      bws_stroom_in
    /\
      bws_detectie
  <->
    bws_stroom_uit
.
  (* Er staat spanning op de uitgang van de bewegingssensor dan en
     slechts dan als er spanning staat op de ingang van de
     bewegingssensor en er beweging is gedetecteerd in de
     afgelopen twee minuten.
  *)

(* Einde van het originele domeinmodel. *)

(*
   Voeg op de plaats van de placeholder hieronder alle nieuwe proposities
   toe (gescheiden door witruimte) die u nodig heeft voor uw installatie.
*)

Variables we_stroom t_ingesteld alarm_aan t_alarm_ingesteld alarm_gaat tijd_alarm: Prop.

(*
   Voeg op de plaatsen van de placeholders hieronder alle specificaties toe
   van de apparaten die u gebruikt in uw installatie.

   Gebruikt u minder onderdelen dan er hier zijn voorgesteld, zet dan
   zoals altijd dummy's neer, bijvoorbeeld
   'Definition ap1 := True.'
*)

Definition alarm :=
        we_stroom
    /\
        t_ingesteld
    /\
        t_alarm_ingesteld
    /\
        alarm_aan
    /\
        tijd_alarm
        ->
            alarm_gaat.

Definition ap1 := True .

Definition ap2 := True .

Definition ap3 := True .

Definition ap4 := True .

Definition ap5 := True .

(*
   Geef hieronder de gewenste eigenschap van uw installatie.
   Verzin een passende naam voor uw complete installatie.
*)

Definition muziekAlarm :=
    we_stroom
        /\
    t_ingesteld
        /\
    t_alarm_ingesteld
        /\
    alarm_aan
        /\
    tijd_alarm
        /\
    cdsp_stroom
        /\
    cdsp_cd
        /\
    verst_aan
        /\
    verst_stroom
    ->
    verst_sol
    /\
    verst_sor

.

(*
   Het is niet onwaarschijnlijk dat de door u gekozen apparaten op
   wiskundig niveau net niet goed aan elkaar gekoppeld worden.
   Om dat probleem op te lossen kunt u hier speciale koppelstukken
   definieren. Denk hierbij aan allerlei soorten kabeltjes, aan adapters,
   aan converters, et cetera.

   Elk van die koppelstukken geeft u een eigen naam en een eigen
   specificatie.

   Heeft u geen kopelstukken nodig, dan moet u hier weer dummy's
   van maken, bijvoorbeeld
   'Definition kop1 := True.'
*)

Definition kabel := alarm_gaat -> cdsp_aan .

Definition muziekL := cdsp_lol -> verst_linel  .

Definition muziekR := cdsp_lor -> verst_liner  .

Definition kop4 := True  .

Definition kop5 := True  .

Definition kop6 := True  .

(*
   En hieronder moet u de correctheidsstelling van uw installatie geven.
   Dat is dus een stelling die zegt dat als u de juiste apparaten aan elkaar
   koppelt (eventueel met koppelstukken) dat dan de hierboven ingevoerde
   'gewenste eigenschap' dan geldt.

   Gebruik hierbij de namen die u hierboven achter de Definition's heeft
   ingevoerd.
*)

Theorem mijnInstallatieWerkt :
  cdsp
  /\
  verst
  /\
  alarm
  /\
  kabel
  /\
  muziekL
  /\
  muziekR
  ->
  muziekAlarm
.
Proof.
(*
   En hier komt het bewijs.
   - Toon de daadwerkelijke definities van apparaat x met 'unfold x.'
   - Doe 'tauto.' als er alleen nog maar atomaire proposities staan.

   Om de verifier niet te laten klagen dat de tactiek 'tauto' wordt
   gebruikt, staat hier een lijst met 15 unfolds.
   Waarschijnlijk is dat meer dan genoeg.

   Voor de regels die u niet nodig heeft, moet er wel echt een
   definitie worden opengevouwen. Echter, dat mag een definitie
   zijn die helemaal niet voorkomt. Dus als dummy kunt u hier
   gebruikmaken van bijvoorbeeld de bewegingssensor:
   'unfold bws.'

   U mag echter geen regels weghalen, want dan vindt de verifier dat u de
   opgave heeft aangepast en krijgt u (hooguit) een oranje vlaggetje.
*)

unfold bws.
unfold cdsp.
unfold verst.
unfold alarm.
unfold muziekAlarm.
unfold kabel.
unfold muziekL.
unfold muziekR.
unfold bws.
unfold bws.
unfold bws.
unfold bws.
unfold bws.
unfold bws.
unfold bws.
tauto.
Qed.


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

Mitchell Riley

June 2016

I am very grateful to Peter LeFanu Lumsdaine, whose unreleased
bicategories code strongly influenced the proofs in this file.

************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.categories.StandardCategories. (* unit *)
Require Import UniMath.CategoryTheory.HorizontalComposition.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Local Open Scope cat.
Require Import UniMath.Bicategories.WkCatEnrichment.prebicategory.

(******************************************************************************)
(* Lemmas for use in PreCat and Cat *)

Definition Catlike_associator ( a b c d : category )
  :
   nat_trans
     (functor_composite
        (pair_functor
           (functor_identity (functor_category a b))
           (functorial_composition b c d ))
        (functorial_composition a b d ))
     (functor_composite
        (precategory_binproduct_assoc (functor_category a b )
           (functor_category b c)
           (functor_category c d ))
        (functor_composite
           (pair_functor
              (functorial_composition a b c )
              (functor_identity (functor_category c d)))
           (functorial_composition a c d ))).
Proof.
  use tpair.
  - (* Step 1: Give the components of the natural transformation *)
    (* I.e., for every triple of functors
         F : a -> b
         G : b -> c
         H : c -> d,
       a natural transformation F (G H) -> (F G) H *)

    intros x.
    simpl.

    (* The component at x is just the identity, because composition of
       functions is associative for free. *)
    exists (λ x, identity _).

    (* Which is natural. *)
    intros oba oba' f.
    use (id_right _ @ !(id_left _)).

  - (* Step 2: Show the above is natural, so given
       f : F -> F', g : G -> G', h : H -> H', *)
    intros [F  [G  H]].
    intros [F' [G' H']].
    intros [f  [g  h]].
    (* Verify that
       (f, (g, h)) ∘ (assoc F' G' H') = (assoc F G H) ∘ ((f, g), h))
       as natural transformations. *)

    (* To show two natural transformations are equal, suffices to
       check components *)
    apply (nat_trans_eq_alt).
    intros oba.

    simpl. do 2 (unfold horcomp_data; simpl).

    (* Now assoc is just identity *)
    rewrite id_right.
    rewrite id_left.

    (* And the order we do f, g, h doesn't matter *)
    rewrite (functor_comp H).
    rewrite assoc.
    apply idpath.
Defined.

Definition Catlike_associator_is_iso ( a b c d : category )
  : ∏ f g h, is_iso (Catlike_associator a b c d
                    (make_catbinprod f (make_catbinprod g h))).
Proof.
  intros f g h.
  (* The components are all the identity, so this is easy *)
  apply functor_iso_if_pointwise_iso.
  intros oba.
  apply (identity_is_iso d).
Defined.

Definition Catlike_left_unitor (a b : category)
  :
  nat_trans
     (functor_composite
        (bindelta_pair_functor
           (functor_composite (functor_to_unit (functor_category a b))
              (constant_functor unit_category (functor_category a a) (functor_identity a)))
           (functor_identity (functor_category a b)))
        (functorial_composition a a b))
     (functor_identity (functor_category a b)).
Proof.
  use tpair.
  - (* Step 1: Give components.
       Again identity works, as function composition is unital for free *)
    intros x.
    exists (λ x, identity _).
    intros oba oba' f.
    exact (id_right _ @ !(id_left _)).

  - (* Step 2: Show the above is natural, so given f : F -> F' *)
    intros F F' f.
    (* Verify that
       (f, id) ∘ (left_unitor F') = (left_unitor F) ∘ f
       as natural transformations. *)

    (* Again just check components *)
    apply (nat_trans_eq_alt).
    intros oba.

    simpl. unfold horcomp_data; simpl.
    rewrite id_right.
    rewrite id_left.
    rewrite (functor_id F).
    apply id_left.
Defined.

Definition Catlike_left_unitor_is_iso (a b : category)
  : ∏ f, is_iso (Catlike_left_unitor a b f).
Proof.
  intros f.
  apply functor_iso_if_pointwise_iso.
  intros oba.
  apply (identity_is_iso b).
Defined.

Definition Catlike_right_unitor (a b : category)
  :
  nat_trans
     (functor_composite
        (bindelta_pair_functor (functor_identity (functor_category a b))
           (functor_composite (functor_to_unit (functor_category a b))
              (constant_functor unit_category (functor_category b b) (functor_identity b))))
        (functorial_composition a b b))
     (functor_identity (functor_category a b)).
Proof.
  use tpair. (* Same as above *)
  - intros x.
    exists (λ x, identity _).
    intros oba oba' f.
    exact (id_right _ @ !(id_left _)).

  - intros F F' f.
    apply (nat_trans_eq_alt).
    intros oba.

    simpl. unfold horcomp_data; simpl.
    rewrite (id_right _).
    rewrite (id_left _).
    apply id_right.
Defined.

Definition Catlike_right_unitor_is_iso (a b : category) :
  ∏ f, is_iso (Catlike_right_unitor a b f).
Proof.
  intros f.
  apply functor_iso_if_pointwise_iso.
  intros oba.
  apply (identity_is_iso b).
Defined.

(* What a mess! *)
Definition Catlike_pentagon ( a b c d e : category )
  (hsB : has_homsets b) (hsC : has_homsets c) (hsD : has_homsets d)
  (hsE : has_homsets e) :
  ∏ k h g f,
  (Catlike_associator a b c e )
     (make_catbinprod k
        (make_catbinprod h ((functorial_composition c d e ) (make_dirprod g f)))) ·
   (Catlike_associator a c d e )
     (make_catbinprod ((functorial_composition_legacy a b c) (make_dirprod k h))
        (make_catbinprod g f))
  = (functor_on_morphisms (functorial_composition_legacy a b e)
      (catbinprodmor (identity k)
         ((Catlike_associator b c d e) (make_catbinprod h (make_catbinprod g f)))) ·
    (Catlike_associator a b d e )
      (make_catbinprod k
         (make_catbinprod ((functorial_composition_legacy b c d ) (make_dirprod h g)) f))) ·
   functor_on_morphisms (functorial_composition_legacy a d e )
     (catbinprodmor
        ((Catlike_associator a b c d ) (make_catbinprod k (make_catbinprod h g)))
        (identity f)).
Proof.
  intros k h g f.
  apply (nat_trans_eq hsE).

  intros oba.
  simpl. unfold horcomp_data; simpl.

  (* Everything boils down to the identity *)
  repeat rewrite functor_id.
  repeat rewrite (id_left _).
  apply idpath.
Defined.

Definition Catlike_triangle ( a b c : category )
  :
   ∏ f g, functor_on_morphisms (functorial_composition_legacy a b c)
                               (catbinprodmor (identity f) (Catlike_left_unitor b c g))
   =
      (Catlike_associator a b b c
        (make_catbinprod f (make_catbinprod (functor_identity b : [ _, _] ) g)))
   · functor_on_morphisms (functorial_composition_legacy a b c)
                           (catbinprodmor (Catlike_right_unitor a b f) (identity g)).
Proof.
  intros f g.
  apply (nat_trans_eq c).
  intros oba.
  simpl. unfold horcomp_data; simpl.
  repeat rewrite functor_id.
  repeat rewrite (id_left _).
  apply idpath.
Defined.

(******************************************************************************)
(* The prebicategory of precategories *)

Definition PreCat_1mor_2mor : prebicategory_ob_hom.
Proof.
  exists category.
  intros a b.
  exact (functor_category a b).
Defined.

Definition PreCat_id_comp : prebicategory_id_comp.
Proof.
  exists PreCat_1mor_2mor.
  split.
  - simpl.
    exact functor_identity.
  - simpl.
    intros a b c.
    exact (functorial_composition_legacy a b c).
Defined.

(*
Definition PreCat_data : prebicategory_data.
Proof.
  unfold prebicategory_data.
  exists PreCat_id_comp.
  repeat split.
  - intros.
    simpl in a,b,c,d.
    exact (Catlike_associator a b c d ).
  - intros.
    simpl in a, b.
    exact (Catlike_left_unitor a b (homset_property a)
                                   (homset_property b)).
  - intros.
    simpl in a, b.
    exact (Catlike_right_unitor a b (homset_property b)).
Defined.

Definition PreCat_has_2mor_set : has_2mor_sets PreCat_data.
Proof.
  unfold has_2mor_sets.
  intros a b f g.
  apply isaset_nat_trans.
  exact (homset_property b).
Defined.

Definition PreCat_associator_and_unitors_are_iso : associator_and_unitors_are_iso PreCat_data.
Proof.
  repeat split.
  - intros a b c d.
    apply Catlike_associator_is_iso.
  - intros a b.
    apply Catlike_left_unitor_is_iso.
  - intros a b.
    apply Catlike_right_unitor_is_iso.
Defined.

Definition PreCat_coherence : prebicategory_coherence PreCat_data.
Proof.
  unfold prebicategory_coherence.
  split.
  - intros a b c d e.
    apply Catlike_pentagon.
  - intros a b c.
    apply Catlike_triangle.
Defined.

Definition PreCat : prebicategory.
Proof.
  use tpair.
  exact PreCat_data.
  split.
  exact PreCat_has_2mor_set.
  split.
  exact PreCat_associator_and_unitors_are_iso.
  exact PreCat_coherence.
Defined.

(******************************************************************************)
(* The bicategory of categories *)

Definition Cat_1mor_2mor : prebicategory_ob_hom.
Proof.
  exists univalent_category.
  intros a b.
  exact (functor_precategory a b (univalent_category_has_homsets b)).
Defined.

Definition Cat_id_comp : prebicategory_id_comp.
Proof.
  exists Cat_1mor_2mor.
  split.
  - simpl.
    exact functor_identity.
  - simpl.
    intros a b c.
    exact (functorial_composition_legacy a b c (univalent_category_has_homsets b)
                                        (univalent_category_has_homsets c)).
Defined.

Definition Cat_data : prebicategory_data.
Proof.
  unfold prebicategory_data.
  exists Cat_id_comp.
  repeat split.
  - intros.
    simpl in a,b,c,d.
    exact (Catlike_associator a b c d (univalent_category_has_homsets b)
                                      (univalent_category_has_homsets c)
                                      (univalent_category_has_homsets d)).
  - intros.
    simpl in a, b.
    exact (Catlike_left_unitor a b (univalent_category_has_homsets a)
                                   (univalent_category_has_homsets b)).
  - intros.
    simpl in a, b.
    exact (Catlike_right_unitor a b (univalent_category_has_homsets b)).
Defined.

Definition Cat_has_2mor_set : has_2mor_sets Cat_data.
Proof.
  unfold has_2mor_sets.
  intros a b f g.
  apply isaset_nat_trans.
  exact (univalent_category_has_homsets b).
Defined.

Definition Cat_associator_and_unitors_are_iso : associator_and_unitors_are_iso Cat_data.
Proof.
  repeat split.
  - intros a b c d.
    apply Catlike_associator_is_iso.
  - intros a b.
    apply Catlike_left_unitor_is_iso.
  - intros a b.
    apply Catlike_right_unitor_is_iso.
Defined.

Definition Cat_coherence : prebicategory_coherence Cat_data.
Proof.
  split.
  - intros a b c d e.
    apply Catlike_pentagon.
  - intros a b c.
    apply Catlike_triangle.
Defined.

Definition Cat_prebicategory : prebicategory.
Proof.
  use tpair.
  exact Cat_data.
  unfold is_prebicategory.
  split.
  exact Cat_has_2mor_set.
  split.
  exact Cat_associator_and_unitors_are_iso.
  exact Cat_coherence.
Defined.

Definition Cat_has_homcats : has_homcats Cat_prebicategory.
Proof.
  unfold has_homcats.
  intros a b.
  apply is_univalent_functor_category.
  apply b.
Defined.

(* TODO: "Should be easy" *)

(* Definition Cat_is_lt2saturated (a b : Cat_prebicategory) *)
(*   : isweq (id_to_internal_equivalence a b). *)
(* Proof. *)

(* Definition Cat : bicategory. *)
(* Proof. *)
(*   exists Cat_prebicategory. *)
(*   split. *)
(*   - exact Cat_has_homcats. *)
(*   - exact Cat_is_lt2saturated. *)
(* Defined. *)

 *)