(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* Finite map library.  *)

(** * FMapFullAVL

   This file contains some complements to [FMapAVL].

   - Functor [AvlProofs] proves that trees of [FMapAVL] are not only
   binary search trees, but moreover well-balanced ones. This is done
   by proving that all operations preserve the balancing.

   - We then pack the previous elements in a [IntMake] functor
   similar to the one of [FMapAVL], but richer.

   - In final [IntMake_ord] functor, the [compare] function is
   different from the one in [FMapAVL]: this non-structural
   version is closer to the original Ocaml code.

*)

Require Import FunInd Recdef FMapInterface FMapList ZArith Int FMapAVL Lia.

Set Implicit Arguments.
Unset Strict Implicit.

Module AvlProofs (Import I:Int)(X: OrderedType).
Module Import Raw := Raw I X.
Module Import II:=MoreInt(I).
Import Raw.Proofs.
Local Open Scope pair_scope.
Local Open Scope Int_scope.

Ltac omega_max := i2z_refl; lia.

Section Elt.
Variable elt : Type.
Implicit Types m r : t elt.

(** * AVL trees *)

(** [avl s] : [s] is a properly balanced AVL tree,
    i.e. for any node the heights of the two children
    differ by at most 2 *)

Inductive avl : t elt -> Prop :=
  | RBLeaf : avl (Leaf _)
  | RBNode : forall x e l r h,
      avl l ->
      avl r ->
      -(2) <= height l - height r <= 2 ->
      h = max (height l) (height r) + 1 ->
      avl (Node l x e r h).

(** * Automation and dedicated tactics about [avl]. *)

Hint Constructors avl.

Lemma height_non_negative : forall (s : t elt), avl s ->
 height s >= 0.
Proof.
 induction s; simpl; intros; auto with zarith.
 inv avl; intuition; omega_max.
Qed.

Ltac avl_nn_hyp H :=
     let nz := fresh "nz" in assert (nz := height_non_negative H).

Ltac avl_nn h :=
  let t := type of h in
  match type of t with
   | Prop => avl_nn_hyp h
   | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
  end.

(* Repeat the previous tactic.
   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)

Ltac avl_nns :=
  match goal with
     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
     | _ => idtac
  end.

(** * Basic results about [avl], [height] *)

Lemma avl_node : forall x e l r, avl l -> avl r ->
 -(2) <= height l - height r <= 2 ->
 avl (Node l x e r (max (height l) (height r) + 1)).
Proof.
  intros; auto.
Qed.
Hint Resolve avl_node.

(** Results about [height] *)

Lemma height_0 : forall l, avl l -> height l = 0 ->
 l = Leaf _.
Proof.
 destruct 1; intuition; simpl in *.
 avl_nns; simpl in *; exfalso; omega_max.
Qed.

(** * Empty map *)

Lemma empty_avl : avl (empty elt).
Proof.
 unfold empty; auto.
Qed.

(** * Helper functions *)

Lemma create_avl :
 forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
 avl (create l x e r).
Proof.
 unfold create; auto.
Qed.

Lemma create_height :
 forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
 height (create l x e r) = max (height l) (height r) + 1.
Proof.
 unfold create; intros; auto.
Qed.

Lemma bal_avl : forall l x e r, avl l -> avl r ->
 -(3) <= height l - height r <= 3 -> avl (bal l x e r).
Proof.
 intros l x e r; functional induction (bal l x e r); intros; clearf;
 inv avl; simpl in *;
 match goal with |- avl (assert_false _ _ _ _) => avl_nns
  | _ => repeat apply create_avl; simpl in *; auto
 end; omega_max.
Qed.

Lemma bal_height_1 : forall l x e r, avl l -> avl r ->
 -(3) <= height l - height r <= 3 ->
 0 <= height (bal l x e r) - max (height l) (height r) <= 1.
Proof.
 intros l x e r; functional induction (bal l x e r); intros; clearf;
 inv avl; avl_nns; simpl in *; omega_max.
Qed.

Lemma bal_height_2 :
 forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 ->
 height (bal l x e r) == max (height l) (height r) +1.
Proof.
 intros l x e r; functional induction (bal l x e r); intros; clearf;
 inv avl; avl_nns; simpl in *; omega_max.
Qed.

Ltac omega_bal := match goal with
  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] =>
     generalize (bal_height_1 x e H H') (bal_height_2 x e H H');
     omega_max
  end.

(** * Insertion *)

Lemma add_avl_1 :  forall m x e, avl m ->
 avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1.
Proof.
 intros m x e; functional induction (add x e m); intros; inv avl; simpl in *.
 intuition; try constructor; simpl; auto; try omega_max.
 (* LT *)
 destruct IHt; auto.
 split.
 apply bal_avl; auto; omega_max.
 omega_bal.
 (* EQ *)
 intuition; omega_max.
 (* GT *)
 destruct IHt; auto.
 split.
 apply bal_avl; auto; omega_max.
 omega_bal.
Qed.

Lemma add_avl : forall m x e, avl m -> avl (add x e m).
Proof.
 intros; generalize (add_avl_1 x e H); intuition.
Qed.
Hint Resolve add_avl.

(** * Extraction of minimum binding *)

Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) ->
 avl (remove_min l x e r)#1 /\
 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1.
Proof.
 intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
 inv avl; simpl in *; split; auto.
 avl_nns; omega_max.
 inversion_clear H.
 rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto.
 split; simpl in *.
 apply bal_avl; auto; omega_max.
 omega_bal.
Qed.

Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) ->
    avl (remove_min l x e r)#1.
Proof.
 intros; generalize (remove_min_avl_1 H); intuition.
Qed.

(** * Merging two trees *)

Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 ->
 -(2) <= height m1 - height m2 <= 2 ->
 avl (merge m1 m2) /\
 0<= height (merge m1 m2) - max (height m1) (height m2) <=1.
Proof.
 intros m1 m2; functional induction (merge m1 m2); intros;
 try factornode _x _x0 _x1 _x2 _x3 as m1.
 simpl; split; auto; avl_nns; omega_max.
 simpl; split; auto; avl_nns; omega_max.
 generalize (remove_min_avl_1 H0).
 rewrite e1; destruct 1.
 split.
 apply bal_avl; auto.
 omega_max.
 omega_bal.
Qed.

Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 ->
  -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2).
Proof.
 intros; generalize (merge_avl_1 H H0 H1); intuition.
Qed.

(** * Deletion *)

Lemma remove_avl_1 : forall m x, avl m ->
 avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1.
Proof.
 intros m x; functional induction (remove x m); intros.
 split; auto; omega_max.
 (* LT *)
 inv avl.
 destruct (IHt H0).
 split.
 apply bal_avl; auto.
 omega_max.
 omega_bal.
 (* EQ *)
 inv avl.
 generalize (merge_avl_1 H0 H1 H2).
 intuition omega_max.
 (* GT *)
 inv avl.
 destruct (IHt H1).
 split.
 apply bal_avl; auto.
 omega_max.
 omega_bal.
Qed.

Lemma remove_avl : forall m x, avl m -> avl (remove x m).
Proof.
 intros; generalize (remove_avl_1 x H); intuition.
Qed.
Hint Resolve remove_avl.

(** * Join *)

Lemma join_avl_1 : forall l x d r, avl l -> avl r ->
 avl (join l x d r) /\
 0<= height (join l x d r) - max (height l) (height r) <= 1.
Proof.
 join_tac.

 split; simpl; auto.
 destruct (add_avl_1 x d H0).
 avl_nns; omega_max.
 set (l:=Node ll lx ld lr lh) in *.
 split; auto.
 destruct (add_avl_1 x d H).
 simpl (height (Leaf elt)).
 avl_nns; omega_max.

 inversion_clear H.
 assert (height (Node rl rx rd rr rh) = rh); auto.
 set (r := Node rl rx rd rr rh) in *; clearbody r.
 destruct (Hlr x d r H2 H0); clear Hrl Hlr.
 set (j := join lr x d r) in *; clearbody j.
 simpl.
 assert (-(3) <= height ll - height j <= 3) by omega_max.
 split.
 apply bal_avl; auto.
 omega_bal.

 inversion_clear H0.
 assert (height (Node ll lx ld lr lh) = lh); auto.
 set (l := Node ll lx ld lr lh) in *; clearbody l.
 destruct (Hrl H H1); clear Hrl Hlr.
 set (j := join l x d rl) in *; clearbody j.
 simpl.
 assert (-(3) <= height j - height rr <= 3) by omega_max.
 split.
 apply bal_avl; auto.
 omega_bal.

 clear Hrl Hlr.
 assert (height (Node ll lx ld lr lh) = lh); auto.
 assert (height (Node rl rx rd rr rh) = rh); auto.
 set (l := Node ll lx ld lr lh) in *; clearbody l.
 set (r := Node rl rx rd rr rh) in *; clearbody r.
 assert (-(2) <= height l - height r <= 2) by omega_max.
 split.
 apply create_avl; auto.
 rewrite create_height; auto; omega_max.
Qed.

Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r).
Proof.
 intros; destruct (join_avl_1 x d H H0); auto.
Qed.
Hint Resolve join_avl.

(** concat *)

Lemma concat_avl : forall m1 m2, avl m1 -> avl m2 -> avl (concat m1 m2).
Proof.
 intros m1 m2; functional induction (concat m1 m2); auto.
 intros; apply join_avl; auto.
 generalize (remove_min_avl H0); rewrite e1; simpl; auto.
Qed.
Hint Resolve concat_avl.

(** split *)

Lemma split_avl : forall m x, avl m ->
  avl (split x m)#l /\ avl (split x m)#r.
Proof.
 intros m x; functional induction (split x m); simpl; auto.
 rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
 simpl; inversion_clear 1; auto.
 rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
Qed.

End Elt.
Hint Constructors avl.

Section Map.
Variable elt elt' : Type.
Variable f : elt -> elt'.

Lemma map_height : forall m, height (map f m) = height m.
Proof.
destruct m; simpl; auto.
Qed.

Lemma map_avl : forall m, avl m -> avl (map f m).
Proof.
induction m; simpl; auto.
inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto.
Qed.

End Map.

Section Mapi.
Variable elt elt' : Type.
Variable f : key -> elt -> elt'.

Lemma mapi_height : forall m, height (mapi f m) = height m.
Proof.
destruct m; simpl; auto.
Qed.

Lemma mapi_avl : forall m, avl m -> avl (mapi f m).
Proof.
induction m; simpl; auto.
inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto.
Qed.

End Mapi.

Section Map_option.
Variable elt elt' : Type.
Variable f : key -> elt -> option elt'.

Lemma map_option_avl : forall m, avl m -> avl (map_option f m).
Proof.
induction m; simpl; auto; intros.
inv avl; destruct (f k e); auto using join_avl, concat_avl.
Qed.

End Map_option.

Section Map2_opt.
Variable elt elt' elt'' : Type.
Variable f : key -> elt -> option elt' -> option elt''.
Variable mapl : t elt -> t elt''.
Variable mapr : t elt' -> t elt''.
Hypothesis mapl_avl : forall m, avl m -> avl (mapl m).
Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m').

Notation map2_opt := (map2_opt f mapl mapr).

Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 ->
 avl (map2_opt m1 m2).
Proof.
intros m1 m2; functional induction (map2_opt m1 m2); auto;
factornode _x0 _x1 _x2 _x3 _x4 as r2; intros;
destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl;
auto using join_avl, concat_avl.
Qed.

End Map2_opt.

Section Map2.
Variable elt elt' elt'' : Type.
Variable f : option elt -> option elt' -> option elt''.

Lemma map2_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2 f m1 m2).
Proof.
unfold map2; auto using map2_opt_avl, map_option_avl.
Qed.

End Map2.
End AvlProofs.

(** * Encapsulation

   We can implement [S] with balanced binary search trees.
   When compared to [FMapAVL], we maintain here two invariants
   (bst and avl) instead of only bst, which is enough for fulfilling
   the FMap interface.
*)

Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.

 Module E := X.
 Module Import AvlProofs := AvlProofs I X.
 Import Raw.
 Import Raw.Proofs.

 Record bbst (elt:Type) :=
  Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}.

 Definition t := bbst.
 Definition key := E.t.

 Section Elt.
 Variable elt elt' elt'': Type.

 Implicit Types m : t elt.
 Implicit Types x y : key.
 Implicit Types e : elt.

 Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt).
 Definition is_empty m : bool := is_empty m.(this).
 Definition add x e m : t elt :=
  Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)).
 Definition remove x m : t elt :=
  Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)).
 Definition mem x m : bool := mem x m.(this).
 Definition find x m : option elt := find x m.(this).
 Definition map f m : t elt' :=
  Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)).
 Definition mapi (f:key->elt->elt') m : t elt' :=
  Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)).
 Definition map2 f m (m':t elt') : t elt'' :=
  Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)).
 Definition elements m : list (key*elt) := elements m.(this).
 Definition cardinal m := cardinal m.(this).
 Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f m.(this) i.
 Definition equal cmp m m' : bool := equal cmp m.(this) m'.(this).

 Definition MapsTo x e m : Prop := MapsTo x e m.(this).
 Definition In x m : Prop := In0 x m.(this).
 Definition Empty m : Prop := Empty m.(this).

 Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt.
 Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt.
 Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt.

 Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
 Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed.

 Lemma mem_1 : forall m x, In x m -> mem x m = true.
 Proof.
 unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto.
 apply m.(is_bst).
 Qed.

 Lemma mem_2 : forall m x, mem x m = true -> In x m.
 Proof.
 unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto.
 Qed.

 Lemma empty_1 : Empty empty.
 Proof. exact (@empty_1 elt). Qed.

 Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
 Proof. intros m; exact (@is_empty_1 _ m.(this)). Qed.
 Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
 Proof. intros m; exact (@is_empty_2 _ m.(this)). Qed.

 Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
 Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed.
 Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
 Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed.
 Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed.

 Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
 Proof.
 unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto.
 apply m.(is_bst).
 Qed.
 Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof. intros m x y e; exact (@remove_2 elt _ x y e m.(is_bst)). Qed.
 Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
 Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed.

 Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
 Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed.
 Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
 Proof. intros m; exact (@find_2 elt m.(this)). Qed.

 Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
 Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed.

 Lemma elements_1 : forall m x e,
   MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
 Proof.
 intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto.
 Qed.

 Lemma elements_2 : forall m x e,
   InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
 Proof.
 intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto.
 Qed.

 Lemma elements_3 : forall m, sort lt_key (elements m).
 Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed.

 Lemma elements_3w : forall m, NoDupA eq_key (elements m).
 Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed.

 Lemma cardinal_1 : forall m, cardinal m = length (elements m).
 Proof. intro m; exact (@elements_cardinal elt m.(this)). Qed.

 Definition Equal m m' := forall y, find y m = find y m'.
 Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
   (forall k, In k m <-> In k m') /\
   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
 Definition Equivb cmp := Equiv (Cmp cmp).

 Lemma Equivb_Equivb : forall cmp m m',
  Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
 Proof.
 intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
 generalize (H0 k); do 2 rewrite In_alt; intuition.
 generalize (H0 k); do 2 rewrite In_alt; intuition.
 generalize (H0 k); do 2 rewrite <- In_alt; intuition.
 generalize (H0 k); do 2 rewrite <- In_alt; intuition.
 Qed.

 Lemma equal_1 : forall m m' cmp,
   Equivb cmp m m' -> equal cmp m m' = true.
 Proof.
 unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
  intros; simpl in *; rewrite equal_Equivb; auto.
 Qed.

 Lemma equal_2 : forall m m' cmp,
   equal cmp m m' = true -> Equivb cmp m m'.
 Proof.
 unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
  intros; simpl in *; rewrite <-equal_Equivb; auto.
 Qed.

 End Elt.

 Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
        MapsTo x e m -> MapsTo x (f e) (map f m).
 Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed.

 Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m.
 Proof.
 intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl.
 apply map_2; auto.
 Qed.

 Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed.
 Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
        (f:key->elt->elt'), In x (mapi f m) -> In x m.
 Proof.
 intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto.
 Qed.

 Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
    (x:key)(f:option elt->option elt'->option elt''),
    In x m \/ In x m' ->
    find x (map2 f m m') = f (find x m) (find x m').
 Proof.
 unfold find, map2, In; intros elt elt' elt'' m m' x f.
 do 2 rewrite In_alt; intros; simpl; apply map2_1; auto.
 apply m.(is_bst).
 apply m'.(is_bst).
 Qed.

 Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
     (x:key)(f:option elt->option elt'->option elt''),
     In x (map2 f m m') -> In x m \/ In x m'.
 Proof.
 unfold In, map2; intros elt elt' elt'' m m' x f.
 do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto.
 apply m.(is_bst).
 apply m'.(is_bst).
 Qed.

End IntMake.

Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
    Sord with Module Data := D
            with Module MapS.E := X.

  Module Data := D.
  Module Import MapS := IntMake(I)(X).
  Import AvlProofs.
  Import Raw.Proofs.
  Module Import MD := OrderedTypeFacts(D).
  Module LO := FMapList.Make_ord(X)(D).

  Definition t := MapS.t D.t.

  Definition cmp e e' :=
   match D.compare e e' with EQ _ => true | _ => false end.

  Definition elements (m:t) :=
    LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)).

  (** * As comparison function, we propose here a non-structural
    version faithful to the code of Ocaml's Map library, instead of
    the structural version of FMapAVL *)

  Fixpoint cardinal_e (e:Raw.enumeration D.t) :=
    match e with
     | Raw.End _ => 0%nat
     | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e)
    end.

  Lemma cons_cardinal_e : forall m e,
   cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat.
  Proof.
   induction m; simpl; intros; auto.
   rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith.
  Qed.

  Definition cardinal_e_2 ee :=
   (cardinal_e (fst ee) + cardinal_e (snd ee))%nat.

  Local Unset Keyed Unification.

  Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t)
   { measure cardinal_e_2 ee } : comparison :=
  match ee with
  | (Raw.End _, Raw.End _) => Eq
  | (Raw.End _, Raw.More _ _ _ _) => Lt
  | (Raw.More _ _ _ _, Raw.End _) => Gt
  | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) =>
      match X.compare x1 x2 with
      | EQ _ => match D.compare d1 d2 with
                | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2)
                | LT _ => Lt
                | GT _ => Gt
                end
      | LT _ => Lt
      | GT _ => Gt
      end
  end.
  Proof.
  intros; unfold cardinal_e_2; simpl;
  abstract (do 2 rewrite cons_cardinal_e; lia ).
  Defined.

  Definition Cmp c :=
   match c with
    | Eq => LO.eq_list
    | Lt => LO.lt_list
    | Gt => (fun l1 l2 => LO.lt_list l2 l1)
   end.

  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2,
   X.eq x1 x2 -> D.eq d1 d2 ->
   Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
  Proof.
   destruct c; simpl; intros; MX.elim_comp; auto.
  Qed.
  Hint Resolve cons_Cmp.

  Lemma compare_aux_Cmp : forall e,
   Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)).
  Proof.
  intros e; functional induction (compare_aux e); simpl in *;
   auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto.
  rewrite 2 cons_1 in IHc; auto.
  Qed.

  Lemma compare_Cmp : forall m1 m2,
    Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _)))
     (Raw.elements m1) (Raw.elements m2).
  Proof.
  intros.
  assert (H1:=cons_1 m1 (Raw.End _)).
  assert (H2:=cons_1 m2 (Raw.End _)).
  simpl in *; rewrite app_nil_r in *; rewrite <-H1,<-H2.
  apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _),
                           Raw.cons m2 (Raw.End _))).
  Qed.

  Definition eq (m1 m2 : t) := LO.eq_list (Raw.elements m1) (Raw.elements m2).
  Definition lt (m1 m2 : t) := LO.lt_list (Raw.elements m1) (Raw.elements m2).

  Definition compare (s s':t) : Compare lt eq s s'.
  Proof.
   destruct s as (s,b,a), s' as (s',b',a').
   generalize (compare_Cmp s s').
   destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto.
  Defined.

  (* Proofs about [eq] and [lt] *)

  Definition selements (m1 : t) :=
   LO.MapS.Build_slist (elements_sort m1.(is_bst)).

  Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
  Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2).

  Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
  Proof.
   unfold eq, seq, selements, elements, LO.eq; intuition.
  Qed.

  Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
  Proof.
   unfold lt, slt, selements, elements, LO.lt; intuition.
  Qed.

  Lemma eq_1 : forall (m m' : t), MapS.Equivb cmp m m' -> eq m m'.
  Proof.
  intros m m'.
  rewrite eq_seq; unfold seq.
  rewrite Equivb_Equivb.
  rewrite Equivb_elements.
  auto using LO.eq_1.
  Qed.

  Lemma eq_2 : forall m m', eq m m' -> MapS.Equivb cmp m m'.
  Proof.
  intros m m'.
  rewrite eq_seq; unfold seq.
  rewrite Equivb_Equivb.
  rewrite Equivb_elements.
  intros.
  generalize (LO.eq_2 H).
  auto.
  Qed.

  Lemma eq_refl : forall m : t, eq m m.
  Proof.
  intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl.
  Qed.

  Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
  Proof.
  intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto.
  Qed.

  Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
  Proof.
  intros m1 m2 M3; rewrite 3 eq_seq; unfold seq.
   intros; eapply LO.eq_trans; eauto.
  Qed.

  Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
  Proof.
  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;
   intros; eapply LO.lt_trans; eauto.
  Qed.

  Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
  Proof.
  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq;
   intros; apply LO.lt_not_eq; auto.
  Qed.

End IntMake_ord.

(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)

Module Make (X: OrderedType) <: S with Module E := X
 :=IntMake(Z_as_Int)(X).

Module Make_ord (X: OrderedType)(D: OrderedType)
 <: Sord with Module Data := D
            with Module MapS.E := X
 :=IntMake_ord(Z_as_Int)(X)(D).


From discprob.basic Require Import base sval order monad bigop_ext nify seq_ext.
Require Import Reals Psatz Omega.

Require ClassicalEpsilon.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
Global Set Bullet Behavior "Strict Subproofs".
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype finset finfun bigop.

Local Open Scope R_scope.
From discprob.monad.idxval Require Import fin_ival pival fin_ival_dist pival_dist.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad.idxval Require extrema.

Import List.

Definition Ex_ival {X} (f: X → R) (I: ival X) : R :=
  \big[Rplus/0]_(i in idx I)
              (f (ind I i) * val I i).

Section Ex_ival_properties.

  Lemma Ex_ival_mret {X} f (r: X):
    Ex_ival f (mret r) = f r.
  Proof.
    rewrite /Ex_ival/index_enum {1}[@Finite.enum]unlock //= big_cons big_nil //=.
    nra.
  Qed.

  Lemma Ex_ival_iplus {X} f (I1 I2: ival X) :
    Ex_ival f (iplus I1 I2) = (Ex_ival f I1) + (Ex_ival f I2).
  Proof.
    rewrite /Ex_ival/index_enum {1}[@Finite.enum]unlock
            /sum_enum big_cat ?big_map //= -?big_distrr //=.
  Qed.

  Lemma Ex_ival_iscale {X} f p (I: ival X) :
    Ex_ival f (iscale p I) =  Rabs p * (Ex_ival f I).
  Proof.
    rewrite /Ex_ival big_distrr //=.
    apply eq_bigr => i ?; nra.
  Qed.

  Lemma Ex_ival_negate {X} f (I: ival X) :
    Ex_ival (λ x, - f x) I = - Ex_ival f I.
  Proof.
    replace (- Ex_ival f I) with (-1 * Ex_ival f I); last by nra.
    rewrite /Ex_ival big_distrr //=.
    apply eq_bigr => ?. nra.
  Qed.

  Lemma Ex_ival_sum_support' {X} (I: ival X) f P :
    \big[Rplus/0]_(i : idx I | P i) (f i * val I i)
      = \big[Rplus/0]_(i : support (val I) | P (sval i)) (f (sval i) * val I (sval i)).
  Proof.
    symmetry.  rewrite /index_enum. apply sum_reidx_map with (h := sval) => //=.
    * intros (a&Hgt) ?? => //=. rewrite -enumT mem_enum //=.
    * intros b _ HP Hneq. specialize (val_nonneg I b).
      destruct 1 as [Hgt|Heq0]; auto.
      exfalso. apply Hneq.
      exists (coerce_supp _ _ Hgt); repeat split; auto.
      rewrite -enumT mem_enum //=.
      rewrite Heq0. nra.
    * rewrite -enumT. apply enum_uniq.
    * rewrite -enumT. apply enum_uniq.
    * intros. by apply sval_inj_pred.
  Qed.

  Lemma Ex_ival_sum_support {X} f (I: ival X) :
    Ex_ival f I
      = \big[Rplus/0]_(i : support (val I)) (f (ind I (sval i)) * val I (sval i)).
  Proof.
    rewrite /Ex_ival. apply (Ex_ival_sum_support' I (λ x, f (ind I x)) (λ x, true)).
  Qed.

  Lemma Ex_ival_sum_support_pred {X} f (I: ival X) :
    Ex_ival f I
      = \big[Rplus/0]_(i | Rgt_dec (val I i) 0) (f (ind I i) * val I i).
  Proof.
    rewrite /Ex_ival.
    rewrite bigop_cond_non0.
    symmetry.
    rewrite bigop_cond_non0.
    apply eq_bigl => //=.
    intros i. destruct Rgt_dec => //=.
    destruct (val_nonneg I i) as [Hgt|Heq] => //=; try nra.
    rewrite Heq Rmult_0_r eq_refl //=.
  Qed.

  Lemma Ex_ival_mono {X} f1 f2 (I: ival X):
    (∀ x, f1 x ≤ f2 x) →
    Ex_ival f1 I ≤ Ex_ival f2 I.
  Proof.
    intros Hf.
    rewrite /Ex_ival; apply Rle_bigr => i Hin.
    specialize (val_nonneg I i) => ?.
    specialize (Hf (ind I i)). nra.
  Qed.

  Lemma Ex_ival_mono_support {X} f1 f2 (I: ival X):
    (∀ x, val I x > 0 → f1 (ind I x) ≤ f2 (ind I x)) →
    Ex_ival f1 I ≤ Ex_ival f2 I.
  Proof.
    intros Hf.
    rewrite /Ex_ival; apply Rle_bigr => i Hin.
    destruct (val_nonneg I i) as [Hgt|Heq0].
    * specialize (Hf i Hgt); nra.
    * rewrite Heq0. nra.
  Qed.

  Lemma Ex_ival_proper' {X} f1 f2 (I1 I2: ival X):
    (∀ x, f1 x = f2 x) →
    eq_ival I1 I2 →
    Ex_ival f1 I1 = Ex_ival f2 I2.
  Proof.
    intros Hext Heq.
    rewrite ?Ex_ival_sum_support.
    destruct Heq as (h1&h2&Hinv&?&Hind&Hval).
    apply (sum_reidx_surj1 _ _ _ _ _ _ (h1)).
    - intros. by rewrite Hext ?Hind ?Hval.
    - intros. split; auto.
      rewrite /index_enum -enumT mem_enum //=.
    - intros b. exists (h2 b). split; auto.
      rewrite /index_enum -enumT mem_enum //=.
    - rewrite /index_enum -enumT. apply enum_uniq.
    - rewrite /index_enum -enumT. apply enum_uniq.
    - intros x1 x2.  intros Heq%(f_equal h2).
      by rewrite ?Hinv in Heq.
  Qed.

  Lemma Ex_ival_proper {X} f (I1 I2: ival X):
    eq_ival I1 I2 →
    Ex_ival f I1 = Ex_ival f I2.
  Proof. intros; by apply Ex_ival_proper'. Qed.

  Global Instance Ex_ival_proper_instance:
    ∀ (X : Type), Proper ((pointwise_relation _ eq) ==> @eq_ival X ==> eq) (Ex_ival).
  Proof.
    intros X f1 f2 ? I1 I2 Heq.
    by apply Ex_ival_proper'.
  Qed.

  Lemma Ex_ival_bind_irrel {X Y} f (I: ival X) (m: ival Y):
    \big[Rplus/0]_i (val m i) = 1 →
    Ex_ival f (mbind (λ x, I) (m: ival Y)) = Ex_ival f I.
  Proof.
    intros Hsum1.
    rewrite {1}/Ex_ival//=.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    etransitivity.
    eapply eq_bigr => i ?.
    { rewrite ?big_map /=.
      etransitivity; first eapply eq_bigr => j ?.
      {
        rewrite -Rmult_assoc Rmult_comm -Rmult_assoc.
        done.
      }
      rewrite /= -big_distrl /= .
      rewrite (eq_bigl (λ x, true)); first done.
      intros j => //=.
    }
    rewrite //=.
    rewrite -big_distrr //=.
    rewrite -[a in _ = a]Rmult_1_r.
    f_equal.
    { rewrite /Ex_ival/index_enum//=. apply congr_big; auto.
      intros; nra. }
    apply Hsum1.
  Qed.

  Lemma Ex_ival_bind_le {X Y1 Y2} f1 f2 (I: ival X) (h1 : X → ival Y1) (h2: X → ival Y2):
    (∀ a, (∃ x, val I x > 0 ∧ ind I x = a) →
                Ex_ival f1 (h1 a) ≤ Ex_ival f2 (h2 a)) →
    Ex_ival f1 (mbind h1 I) ≤ Ex_ival f2 (mbind h2 I).
  Proof.
    intros Hh.
    rewrite ?Ex_ival_sum_support_pred.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    rewrite /index_enum {3}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    eapply Rle_bigr => i ?.
    rewrite ?big_map //=.
    destruct (val_nonneg I i) as [Hgt|Heq]; last first.
    { rewrite Heq //=. transitivity 0; right.
      * rewrite big1 //= => i'. rewrite Rmult_0_l. destruct Rgt_dec => //=; nra.
      * rewrite big1 //= => i'. rewrite Rmult_0_l. destruct Rgt_dec => //=; nra.
    }
    assert ( val I i * Ex_ival f1 (h1 (ind I i)) ≤ val I i * Ex_ival f2 (h2 (ind I i))) as Hle'.
    { apply Rmult_le_compat_l; first apply Rge_le, val_nonneg.
      eapply Hh; eauto.
    }
    etransitivity; first (etransitivity; last eapply Hle').
    - rewrite Ex_ival_sum_support_pred.
      rewrite big_distrr.
      rewrite //=.
      right. apply congr_big  => //=.
      * intros i' => //=. repeat destruct Rgt_dec => //=; nra.
      * intros i' Hgt'. nra.
    - rewrite Ex_ival_sum_support_pred.
      rewrite big_distrr.
      rewrite //=.
      right. apply congr_big  => //=.
      * intros i' => //=. repeat destruct Rgt_dec => //=; nra.
      * intros i' Hgt'. nra.
  Qed.

  Lemma Ex_ival_bind_eq {X Y1 Y2} f1 f2 (I: ival X) (h1: X → ival Y1) (h2: X → ival Y2):
    (∀ a, (∃ x, val I x > 0 ∧ ind I x = a) →
                Ex_ival f1 (h1 a) = Ex_ival f2 (h2 a)) →
    Ex_ival f1 (mbind h1 I) = Ex_ival f2 (mbind h2 I).
  Proof.
    intros Hcontinue; apply Rle_antisym; apply Ex_ival_bind_le.
    - intros a (?&?&?).
      right; apply Hcontinue; eauto.
    - intros a (?&?&?).
      right; symmetry; apply Hcontinue; eauto.
  Qed.

  Lemma Ex_ival_ivdplus {X} f p Hpf (I1 I2: ivdist X) :
    Ex_ival f (ivdplus p Hpf I1 I2 : ival X) = p * Ex_ival f I1 + (1 - p) * Ex_ival f I2.
  Proof.
    rewrite /ivdplus//= Ex_ival_iplus !Ex_ival_iscale.
    rewrite ?Rabs_right //=; nra.
  Qed.

  Lemma Ex_ival_bind_post {X Y} f (I: ival X) (h: X → ival Y):
    Ex_ival f (x ← I; h x) = Ex_ival (λ x, Ex_ival f (h x)) I.
  Proof.
    rewrite /Ex_ival//=.
    rewrite /index_enum {1}[@Finite.enum]unlock //=.
    rewrite /tag_enum big_flatten //= big_map.
    apply eq_bigr => i Hin.
    rewrite big_map => //=.
    rewrite big_distrl => //=.
    apply eq_bigr => ??.
    nra.
  Qed.

End Ex_ival_properties.

Definition Ex_ivd {X} (f: X → R) (I: ivdist X) : R := Ex_ival f I.

Section Ex_ivd_properties.

  Lemma Ex_ivd_plus {X} f p Hpf (I1 I2: ivdist X) :
    Ex_ivd f (ivdplus p Hpf I1 I2) = p * Ex_ivd f I1 + (1 - p) * Ex_ivd f I2.
  Proof. apply Ex_ival_ivdplus. Qed.

  Lemma Ex_ivd_bind_irrel {X Y} f (I: ivdist X) (m: ivdist Y):
    Ex_ivd f (mbind (λ x, I) m) = Ex_ivd f I.
  Proof.
    rewrite /Ex_ivd//=.
    apply Ex_ival_bind_irrel, val_sum1.
  Qed.

  Lemma Ex_ivd_plus_const {X} f (I: ivdist X) k:
    Ex_ivd (λ x, f x + k) I = Ex_ivd f I + k.
  Proof.
    rewrite /Ex_ival.
    etransitivity.
    { eapply eq_bigr => i Hin.
      rewrite Rmult_plus_distr_r. done.
    }
    rewrite big_split => //=; f_equal.
    rewrite -big_distrr.
    rewrite val_sum1 => //=. nra.
  Qed.

  Lemma Ex_ivd_scale_const {X} f (I: ivdist X) k:
    Ex_ivd (λ x, k * (f x)) I = k * (Ex_ivd f I).
  Proof.
    rewrite /Ex_ivd/Ex_ival//=.
    rewrite big_distrr => //=.
    apply eq_bigr => ??; nra.
  Qed.

  Lemma Ex_ivd_const {X} (I: ivdist X) k:
    Ex_ivd (λ x, k) I = k.
  Proof.
    rewrite /Ex_ivd/Ex_ival//=.
    rewrite -big_distrr val_sum1 => //=; nra.
  Qed.

  Lemma Ex_ivd_ivdplus {X} f p Hpf (I1 I2: ivdist X) :
    Ex_ivd f (ivdplus p Hpf I1 I2) = p * Ex_ivd f I1 + (1 - p) * Ex_ivd f I2.
  Proof.
    rewrite /Ex_ivd. rewrite Ex_ival_ivdplus //=.
  Qed.

  Lemma Ex_ivd_sum {X} (f1 f2: X → R) (I: ivdist X):
    Ex_ivd (λ x, f1 x + f2 x) I = Ex_ivd f1 I + Ex_ivd f2 I.
  Proof.
    rewrite /Ex_ivd/Ex_ival. etransitivity.
    { eapply eq_bigr => i ?. ring_simplify. done. }
    rewrite //=. apply big_split.
  Qed.

  Global Instance Ex_ivd_proper_instance:
    ∀ (X : Type), Proper ((pointwise_relation _ eq) ==> @eq_ivd X ==> eq) (Ex_ivd).
  Proof.
    intros X f1 f2 ? I1 I2 Heq.
    by apply Ex_ival_proper'.
  Qed.

End Ex_ivd_properties.

From discprob.monad.idxval Require Import pidist_fin_singleton.

Lemma ex_Ex_extrema_singleton {X} f (I: ivdist X):
  extrema.ex_Ex_extrema f (singleton I).
Proof.
  intros I' <-.
  rewrite /extrema.ex_Ex_ival.
  rewrite //=. eexists. apply SeriesF_is_seriesC.
Qed.

Lemma is_Ex_ival_fin {X} f (I: ival X):
  extrema.is_Ex_ival f (fin_coerce I) (Ex_ival f I).
Proof.
  rewrite /extrema.is_Ex_ival/extrema.ex_Ex_ival.
  split.
  * rewrite //=. eexists. apply SeriesF_is_seriesC.
  * rewrite //=. apply Series_correct'.
    ** rewrite SeriesC_SeriesF SeriesF_big_op //=.
    ** eexists; apply SeriesF_is_seriesC.
Qed.

Import Lub Rbar.

Lemma Ex_min_singleton {X} f (I: ivdist X):
  extrema.Ex_min f (singleton I) = Finite (Ex_ival f I).
Proof.
  rewrite fin_singleton_equiv_singleton extrema.Ex_min_singleton.
  * rewrite //=. f_equal. apply extrema.is_Ex_ival_unique.
    apply is_Ex_ival_fin.
  * rewrite //=. eapply extrema.is_Ex_ival_ex. apply is_Ex_ival_fin.
Qed.

Lemma Ex_max_singleton {X} f (I: ivdist X):
  extrema.Ex_max f (singleton I) = Finite (Ex_ival f I).
Proof.
  rewrite fin_singleton_equiv_singleton extrema.Ex_max_singleton.
  * rewrite //=. f_equal. apply extrema.is_Ex_ival_unique.
    apply is_Ex_ival_fin.
  * rewrite //=. eapply extrema.is_Ex_ival_ex. apply is_Ex_ival_fin.
Qed.


(* Adequacy of Operational Semantics vs. Sampling Semantics *)

(* We don't bother with soundness, which is (or should be) dull *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Program.
Require Import EqNat.

Require Import LiftedTypes.
Require Import MyReals.

Require Import Types.
Require Import Syntax.
Require Import SamplingSemantics.
Require Import Substitutions.
Require Import OperationalSemantics.

(* false_invert: tactic from SF *)
(* false_invert proves any goal provided there is at least one *)
(* hypothesis H in the context that can be proved absurd by calling *)
(* inversion H. *)

Ltac false_invert :=
  intros;
  match goal with
    [ H:_ |- _ ] => solve [ inversion H ]
  end.

(* **************************************************************** *)

(* The Logical Relation *)

(* Defined as a fixed point over Otypes and lifted Otypes *)

Definition EqReal : (den_Mtype Real_type) ->
                    (den_Mtype Real_type) -> Prop :=
  fun v1 v2 => (v1 = v2).

Function Prod_Rel {ma mb : Mtype}
         (RA : (den_Mtype ma) -> (Val nil (Stype ma)) -> Prop)
         (RB : (den_Mtype mb) -> (Val nil (Stype mb)) -> Prop)
         (p  : (den_Mtype (Prod_type ma mb)))
         (val : (Val nil (Stype (Prod_type ma mb))))
  :=
    exists e1 e2, val = prodval e1 e2 /\
                  (RA (fst p) e1) /\ (RB (snd p) e2).

Function Real_Rel (d : (den_Mtype Real_type))
         (val : (Val nil (Stype Real_type)))
  :=
    exists n, val = constexp n /\ d = n.

(* relation between syntactic values of measurable type and *)
(* denotations of that type *)

Fixpoint Mtype_Rel (m : Mtype)
  : (den_typeS (Stype m)) -> (Val nil (Stype m)) -> Prop :=
  match m with
  | Real_type => Real_Rel
  | Prod_type m1 m2 => Prod_Rel (Mtype_Rel m1) (Mtype_Rel m2)
  end.

(* General recipe for lifting a relation *)
(* (liftRel o R d e) iff d is bottom or d = lift(a) and e evaluates to *)
(* a value v such (Rel a v) holds*)

Function lift_Rel {o : Otype} (R : (den_typeS o) -> (Val nil o) -> Prop)
: (lifted (den_typeS o)) -> (Exp nil o) -> Prop :=
  fun d e =>
    match d with
      | bottom => True
      | lift a => exists v, ev e v /\ R a v
    end.

Definition  Fun_Rel {o1 o2}
            (Rel1 : (den_typeS o1) -> (Val [] o1) -> Prop)
            (Rel2 : (lifted (den_typeS o2)) -> (Exp [] o2) -> Prop)
            (f1 : (den_typeS o1) -> (lifted (den_typeS o2)))
            (val1 : Val nil (Funtype o1 o2))
: Prop :=
  exists e, val1 = absexp e /\
  forall (a1 : den_typeS o1) (val2: Val [] o1),
    (Rel1 a1 val2) ->
    (Rel2 (f1 a1) (ap_Se (subst1 val2) e)).

Definition Meas_Rel
           (m : Mtype)
           (s : den_typeS (Meastype m))
           (c : Val nil (Meastype m)) : Prop :=
  forall (u:Unit),
    match (s u) with
      | bottom => True
      | lift a => exists c', evs u c c' /\ Mtype_Rel m a c'
    end.

(* This is as far as I got.  Need to fix up Rel to match the types in *)
(* Types.v and ImportanceSampling.v *)

Fixpoint Rel {o : Otype} : (den_typeS o) -> (Val nil o) -> Prop :=
  match o with
  | Stype m => fun d => Mtype_Rel m d
  | Funtype o1 o2 => Fun_Rel (@Rel o1)  (lift_Rel (@Rel o2))
  | Meastype m => Meas_Rel m
  end.

Fixpoint Rel_Env {G} : (den_env G) -> (Subst G nil) -> Prop :=
  match G with
    | nil => fun r s => True
    | (o :: G') => fun (r : den_env (o::G')) s =>
                     Rel (fst r) (hd_subst s)
                     /\ Rel_Env (snd r) (tl_subst s)
  end.

Lemma lookup_preserves_Rel : forall G (o : Otype)
                       (var : Var G o)
                       (r : den_env G)
                       (s : Subst G nil),
                                Rel_Env r s
                                -> Rel (apply_env r var) (s _ var).
Proof.
  intros.
  induction G as [| o' G'].
  (* G = [] *)
  inversion var.
  (* G = o' :: G' *)
  induction var as [| G''].
  (* var = var_0 *)
  simpl.
  inversion H.
  apply H0.
  (* var = var_S v' *)
  apply (IHvar (snd r) (tl_subst s)).
  apply H.
  intros.
  apply IHG'.
  apply H0.
Qed.

Lemma extend_env_preserves_Rel :
  forall (o: Otype) G r (s : Subst G nil) (d : den_typeS o) (val: Val nil o),
    Rel_Env r s -> Rel d val
    -> Rel_Env (cons_env d r) (cons_subst val s).
Proof.
  intros.
  simpl.
  split.
  apply H0.
  apply H.
Qed.

(* Lemma bind_preserves_Rel : *)
(*   forall m m' *)
(*          (s1 : Unit -> lifted (den_typeS (Stype m))) *)
(*          (f : (den_typeS (Stype m)) *)
(*               -> lifted *)
(*                    (Unit *)
(*                     -> lifted (den_typeS (Stype m')))) *)
(*          c1 c2, *)
(*     Meas_Rel m s1 c1 -> *)
(*     Fun_Rel (Rel ) (lift_Rel (Meas_Rel m')) f c2 -> *)
(*     Meas_Rel m' (bindopS s1 f) (bindval c1 c2). *)
(* Proof.     *)
(*   intros. *)
(*   unfold Meas_Rel. *)
(*   intros u. *)
(*   destruct (bindopS s1 f u) as [| b] eqn: f_u; auto. *)
(*   unfold bindopS in f_u. *)
(*   destruct (s1 (left_half u)) as [| a] eqn: s1_uL; try false_invert; auto. *)

(*   (* (s1 u_L) = lift a *) *)
(*   destruct (f a) as [| s'] eqn: f_a; try false_invert; auto. *)
(*   simpl in f_u. *)
(*   rewrite f_a in f_u. *)
(*   simpl in f_u. *)
(*   inversion f_u. *)

(*   (* (f a) = lift s' *) *)
(*   destruct (s' (right_half u)) as [| b'] eqn: s'_uR; auto. *)

(*   (* (s' u_R) = bottom *) *)
(*   simpl in f_u. *)
(*   rewrite f_a in f_u. *)
(*   simpl in f_u. *)
(*   rewrite s'_uR in f_u. *)
(*   inversion f_u. *)

(*   (* (s' u_R) = lift b *) *)
(*   simpl in f_u. *)
(*   rewrite f_a in *. *)
(*   simpl in f_u. *)

(*   assert (Hc3: exists c3, (evs (left_half u) c1 c3) /\ Rel a c3). *)
(*   { rewrite s'_uR in *. *)
(*     inversion f_u. *)
(*     rewrite H2 in *. *)
(*     clear f_u. *)
(*     unfold Fun_Rel in H0. *)
(*     inversion H0 as [e2]. clear H0. inversion H1. clear H1. *)
(*     unfold Meas_Rel in H. *)
(*     specialize (H (left_half u)). *)
(*     rewrite s1_uL in H. *)
(*     inversion H as [c3]; clear H. *)
(*     exists c3. *)
(*     apply H1. } *)

(*   inversion Hc3 as [c3]; clear Hc3. *)
(*   inversion H1; clear H1. *)
(*   unfold Fun_Rel in H0. *)
(*   inversion H0 as [e2']; simpl; clear H0. *)
(*   inversion H1; clear H1. *)
(*   specialize (H4 a c3 H3). *)
(*   unfold lift_Rel in H4. *)
(*   rewrite f_a in H4. *)
(*   inversion H4 as [c4]; clear H4. *)
(*   inversion H1; clear H1. *)
(*   unfold Meas_Rel in H5. *)
(*   specialize (H5 (right_half u)). *)
(*   rewrite s'_uR in *. *)
(*   inversion H5 as [c5]; clear H5. *)
(*   exists c5. *)
(*   inversion H1; clear H1. *)
(*   inversion f_u as [eq_b] ; clear f_u. *)
(*   rewrite eq_b in *. *)
(*   split. *)
(*   assert (H10: ev (appexp (valexp c2) (valexp c3)) c4). *)
(*   { rewrite H0 in *. *)
(*     assert (H12: ev (valexp (absexp e2')) (absexp e2')) by apply ev_val. *)
(*     assert (H13: ev (valexp c3) c3) by apply ev_val. *)

(*     Check ev_app. *)
(*     apply (ev_app H12 H13 H4). *)
(*   } *)
(*   apply (evs_bind H2 H10 H5). *)
(*   (* woo-hoo! *) *)
(*   apply H6. *)
(* Qed. *)

(* Here's a cleaner proof of this. *)

Lemma bind_preserves_Rel :
  forall m m'
         (s1 : Unit -> lifted (den_typeS (Stype m)))
         (f : (den_typeS (Stype m))
              -> lifted
                   (Unit
                    -> lifted (den_typeS (Stype m'))))
         c1 c2,
    Meas_Rel m s1 c1 ->
    Fun_Rel (Rel ) (lift_Rel (Meas_Rel m')) f c2 ->
    Meas_Rel m' (bindopS s1 f) (bindval c1 c2).
Proof.
  intros.
  unfold Meas_Rel.
  intros.
  destruct (bindopS s1 f u) as [|b]  eqn: f_u; try false_invert; auto.
  unfold bindopS in f_u.
  destruct (s1 (left_half u)) eqn: s1_uL; try false_invert; simpl in *; auto.
  destruct (f d) as [| s2] eqn: f_d; try false_invert; auto.
  simpl in f_u.
  destruct (s2 (right_half u)) as [| b'] eqn: s2_uR; try false_invert; simpl in *; auto.
  rewrite f_u in *.

  (* now we have all the denotations, next let's work on the
     reductions *)

  (* First reduction: evs (left_half u) c1 c3 *)
  unfold Meas_Rel in H.
  specialize (H (left_half u)).
  rewrite s1_uL in H; simpl in H.
  inversion H as [c3]; clear H.
  inversion H1 as [Red1a Red1b]; clear H1.

  (* second reduction: ev (appexp (valexp c2) (valexp c3)) c4 *)
  (* c2: is a function, so it has to be an abstraction *)

  unfold Fun_Rel in H0.
  inversion H0 as [e]; clear H0.
  inversion H; clear H.
  specialize (H1 _ _ Red1b).
  unfold lift_Rel in H1.
  rewrite f_d in *; simpl in *.
  inversion H1 as [c4]; clear H1.
  inversion H; clear H.

  assert (Red2: ev (appexp (valexp c2) (valexp c3)) c4).
  assert (Red2a: ev (valexp c2) c2) by apply ev_val.
  assert (Red2b: ev (valexp c3) c3) by apply ev_val.
  rewrite H0 in *.
  apply (ev_app Red2a Red2b H1).

  (* now for the last step *)
  unfold Meas_Rel in H2.
  specialize (H2 (right_half u)).
  rewrite s2_uR in *.
  inversion H2 as [c5]; clear H2.
  inversion H as [Red3a Red3b].
  exists c5.
  split.
  apply (evs_bind Red1a Red2 Red3a).
  apply Red3b.
Qed.

Hint Resolve bind_preserves_Rel.

Lemma return_preserves_Rel :
  forall m (v : den_typeS (Stype m)) (c : Val nil (Stype m)),
         Rel v c ->
         Meas_Rel m (returnopS v) (returnval c).
Proof.
  intros.
  unfold returnopS.
  unfold Meas_Rel.
  intros.
  exists c.
  split.
  apply evs_return.
  apply H.
Qed.

Hint Resolve return_preserves_Rel.

Lemma unif_preserves_Rel :
  Meas_Rel _ uniformopS uniformval.
Proof.
  unfold Meas_Rel.
  intros.
  unfold uniformopS.
  exists (constexp (unit_real u)).
  split.
  apply evs_unif.
  unfold Mtype_Rel.
  unfold Real_Rel.
  eauto.
Qed.

Hint Resolve unif_preserves_Rel.

(* **************************************************************** *)

(* The Fundamental Theorem *)

Definition Fun_Thm_Exp G o  (exp: Exp G o) :=
  forall
         (r : den_env G)
         (s : Subst G nil),
    Rel_Env r s
    -> lift_Rel (@Rel o) (den_expS exp r) (ap_Se s exp).

Definition Fun_Thm_Val G o   (val: Val G o):=
  forall

         (r : den_env G)
         (s : Subst G nil),
    Rel_Env r s
    -> @Rel o (den_valS val r) (ap_Sv s val).

Theorem Fund_Thm: forall G o exp, @Fun_Thm_Exp G o exp.
Proof.
  apply (exp_val_rec Fun_Thm_Exp Fun_Thm_Val);
  unfold Fun_Thm_Exp;
  unfold Fun_Thm_Val;
  intros;
  simpl.

  (* valexp *)
  { specialize (H _ _ H0).
    exists (ap_Sv s v).
    split.
    apply ev_val.
    apply H.
    }

  { (* prodexp e1 e2 *)
    intros.
    specialize (H _ _ H1).
    specialize (H0 _ _ H1).
    destruct (den_expS e r), (den_expS e0 r); simpl; auto.
    simpl in *.
    inversion H.
    inversion H0.
    exists (prodval x x0).
    inversion H2; clear H2.
    inversion H3; clear H3.
    split.
    apply ev_prod; auto.
    unfold Prod_Rel.
    eauto.
  }

  { (* proj1exp e *)
    specialize (H r s H0); clear H0.
    destruct (den_expS e r); simpl; auto.
    inversion H. clear H. inversion H0. clear H0.
    unfold Rel in H1.
    simpl in H1.
    unfold Prod_Rel in H1.
    inversion H1; clear H1.
    inversion H0; clear H0.
    inversion H1; clear H1.
    inversion H2; clear H2.
    exists x0.
    split.
    apply (ev_proj1 _ x0 x1).
    rewrite H0 in H.
    apply H.
    auto.
  }

 { (* proj2exp e *)
    specialize (H r s H0); clear H0.
    destruct (den_expS e r); simpl; auto.
    inversion H. clear H. inversion H0. clear H0.
    unfold Rel in H1.
    simpl in H1.
    unfold Prod_Rel in H1.
    inversion H1; clear H1.
    inversion H0; clear H0.
    inversion H1; clear H1.
    inversion H2; clear H2.
    exists x1.
    split.
    apply (ev_proj2 _ x0 x1).
    rewrite H0 in H.
    apply H.
    auto.
  }

 { (* appexp e e0 *)
    specialize (H _ _ H1).
    specialize (H0 _ _ H1).
    destruct (den_expS e r), (den_expS e0 r);
      try false_invert; auto; simpl in *.

    (* work out the first reduction *)
    inversion H as [c2]; clear H.
    inversion H2; clear H2.
    inversion H3 as [e']; clear H3.
    inversion H2; clear H2.
    rewrite H3 in *.
    (* H: ev (ap_Se s e) (absexp e') *)

    (* work out the second reduction *)
    inversion H0 as [v]; clear H0.
    inversion H2; clear H2.
    (* H0: ev (ap_Se s e0) v *)

    (* now the third reduction *)
    specialize (H4 d0 v H5).
    destruct (d d0); try false_invert; auto; simpl in *.
    inversion H4 as [w]; clear H4.
    exists w.
    inversion H2; clear H2.
    split.
    apply (ev_app H H0 H4).
    auto.

  }

  (* bindexp e e0 *)
  { specialize (H _ _ H1).
    specialize (H0 _ _ H1).
    destruct (den_expS e r), (den_expS e0 r);
      try false_invert; auto.
    simpl in *.
    inversion H as [c1]; clear H.
    inversion H2; clear H2.
    inversion H0 as [c2]; clear H0.
    inversion H2; clear H2.
    exists (bindval c1 c2).
    split.
    apply ev_bind; auto.
    apply bind_preserves_Rel; auto. }

  (* returnexp e *)
  { specialize (H _ _ H0).
    unfold lift_Rel.
    destruct (den_expS e r) as [|v1] eqn: eq_e; auto.
    simpl.
    unfold lift_Rel in H.
    inversion H as [v]; clear H.
    inversion H1; clear H1.
    exists (returnval v).
    split.
    apply ev_return.
    apply H.
    apply return_preserves_Rel.
    apply H2. }

  (* constexp *)
  { unfold coerce_realS.
    unfold Real_Rel.
    eauto. }

  { (* prodexp *)
    specialize (H r s H1).
    specialize (H0 r s H1).
    unfold Prod_Rel.
    eauto.
    }

  (* varexp *)
    apply lookup_preserves_Rel. apply H.

  { (* absexp *)
    unfold Fun_Rel.
    exists (ap_Se (shift_subst s) e).
    split; auto.
    intros.

    assert (H2: (Rel_Env (cons_env a1 r) (cons_subst val2 s))).
    apply extend_env_preserves_Rel; auto.
    specialize (H _ _ H2).

    assert (H3: (ap_Se (cons_subst val2 s) e)
                =
                (ap_Se (subst1 val2) (ap_Se (shift_subst s) e))).
    rewrite <- cSS_subst1.
    rewrite <- ap_cSS_e.
    auto.
    rewrite <- H3 in *.
    apply H.
    }

  { (* uniformval *)
    unfold Meas_Rel.
    intros.
    unfold uniformopS.
    exists (constexp (unit_real u)).
    split.
    apply evs_unif.
    simpl.
    unfold Real_Rel.
    eauto.
    }

  { (* bindval *)
    apply bind_preserves_Rel.
    specialize (H _ _ H1).
    specialize (H0 _ _ H1).
    apply H.
    specialize (H0 _ _ H1).
    apply H0.
  }

  { (* returnval *)
    apply return_preserves_Rel.
    specialize (H _ _ H0).
    apply H. }
Qed.


From Coq Require Export NArith List Number Decimal.

From stdpp Require Import gmap sorting.

Set Implicit Arguments.
Set Contextual Implicit.

Import ListNotations.

Record DIGITS := { unDIGITS : list N }.

Fixpoint decimal_to_digits (d : Decimal.uint) : list N :=
  match d with
  | D0 d => 0 :: decimal_to_digits d
  | D1 d => 1 :: decimal_to_digits d
  | D2 d => 2 :: decimal_to_digits d
  | D3 d => 3 :: decimal_to_digits d
  | D4 d => 4 :: decimal_to_digits d
  | D5 d => 5 :: decimal_to_digits d
  | D6 d => 6 :: decimal_to_digits d
  | D7 d => 7 :: decimal_to_digits d
  | D8 d => 8 :: decimal_to_digits d
  | D9 d => 9 :: decimal_to_digits d
  | Nil => []
  end%N.

Definition decimal_to_DIGITS (d : Number.uint) :=
  match d with
  | UIntDecimal d => Some {| unDIGITS := decimal_to_digits d |}
  | _ => None
  end.

Definition dummy_from_DIGITS : DIGITS -> option Number.uint := fun _ => None.

Declare Scope DIGITS_scope.
Delimit Scope DIGITS_scope with DIGITS.

Number Notation DIGITS decimal_to_DIGITS dummy_from_DIGITS : DIGITS_scope.

Definition Input : Type := list (list N).

Notation "'input' x .. y" := (map unDIGITS (cons x%DIGITS .. (cons y%DIGITS nil) ..))
  (at level 200, x at level 0, only parsing).

Definition example : Input := input
2199943210
3987894921
9856789892
8767896789
9899965678
.

#[local] Open Scope bool_scope.
#[local] Open Scope N_scope.

(* Add sentinel values *)
Definition pad (xs : Input) : Input :=
  let sentinel_row :=
    match xs with
    | [] => []
    | x :: _ => 10 :: 10 :: map (fun _ => 10) x
    end in
  sentinel_row :: map (fun x => 10 :: x ++ [10])%N xs ++ [sentinel_row].

Fixpoint find_local_min_row (r1 r2 r3 : list N) : list N :=
  match r1, r2, r3 with
  | _11 :: (x12 :: _13 :: _) as r1,
    x21 :: (x22 :: x23 :: _) as r2,
    _31 :: (x32 :: _33 :: _) as r3 =>
    if (x22 <? x12) && (x22 <? x21) && (x22 <? x23) && (x22 <? x32) then
      x22 :: find_local_min_row r1 r2 r3
    else
      find_local_min_row r1 r2 r3
  | _, _, _ => []
  end.

Fixpoint find_local_min (xs : Input) : list N :=
  match xs with
  | r1 :: (r2 :: r3 :: _) as xs =>
    find_local_min_row r1 r2 r3 ++ find_local_min xs
  | _ => []
  end.

Definition sum_N : list N -> N := fold_right N.add 0.

Definition solve (xs : Input) : N :=
  let ys := find_local_min (pad xs) in
  sum_N (map N.succ ys).

(* Compute solve example. *)

Module St.

Section St.

Context (S : Type).

Record m (A : Type) : Type := Mk { run : S -> S * A }.

Definition pure {A} (a : A) : m A := Mk (fun s => (s, a)).

Definition bind {A B} (u : m A) (k : A -> m B) : m B :=
  Mk (fun s =>
    let sa := run u s in
    run (k (snd sa)) (fst sa)).

Fixpoint concat_for {A B} (cat : B -> B -> B) (dog : B) (xs : list A) (f : A -> m B) : m B :=
  match xs with
  | nil => pure dog
  | x :: xs =>
    bind (f x) (fun y =>
    bind (concat_for cat dog xs f) (fun ys =>
    pure (cat y ys)))
  end.

Fixpoint for_ {A} (xs : list A) (f : A -> m unit) : m unit :=
  match xs with
  | nil => pure tt
  | x :: xs => bind (f x) (fun _ => for_ xs f)
  end.

End St.
End St.

Notation "'let*' a ':=' u 'in' v" := (St.bind u (fun a => v)) (at level 200, a binder).

Definition isSome {A} (x : option A) :=
  match x with
  | Some _ => true
  | None => false
  end.

(* [gset] insertion (as [fun x s => union (singleton x) s]) is slow,
   so we redefine our own sets from maps which have fast [insert]. *)
Notation set X := (gmap X unit).
Notation insert_set x s := (insert x tt s).
Notation elem_set x s := (isSome (lookup x s)).

Section CC.

Context (V : Type) `{Countable V}.

Record graph : Type :=
  { nodes : list V
  ; neighbors : V -> list V
  }.

Record CC_state : Type :=
  { visited : set V
  ; cur_component : list V
  }.

Definition check_visited (v : V) : St.m CC_state bool :=
  St.Mk (fun s => (s, elem_set v (visited s))).

Definition visit (v : V) : St.m CC_state unit :=
  St.Mk (fun s =>
    ( {| visited := insert_set v (visited s)
      ;  cur_component := v :: cur_component s |}
    , tt)).

Definition reset_cur_component : St.m CC_state unit :=
  St.Mk (fun s =>
    ( {| visited := visited s ; cur_component := nil |}
    , tt)).

Definition get_cur_component : St.m CC_state (list V) :=
  St.Mk (fun s => (s, cur_component s)).

Fixpoint create_component (g : graph) (fuel : nat) (v : V) : St.m CC_state unit :=
  let* bvisited := check_visited v in
  if bvisited then
    St.pure tt
  else match fuel with | O => St.pure tt | S fuel =>
    let* _ := visit v in
    St.for_ (neighbors g v) (create_component g fuel)
  end.

Fixpoint _connected_components (g : graph) (fuel : nat) (vs : list V) (cc : list (list V))
  : St.m CC_state (list (list V)) :=
  match vs with
  | nil => St.pure cc
  | v :: vs =>
    let* _ := reset_cur_component in
    let* _ := create_component g fuel v in
    let* c := get_cur_component in
    let cc :=
      match c with
      | nil => (* Already visited *) cc
      | _ :: _ => c :: cc
      end in
    _connected_components g fuel vs cc
  end.

Definition connected_components (g : graph) : list (list V) :=
  snd (St.run
    (_connected_components g (length (nodes g)) (nodes g) nil)
    {| visited := empty ; cur_component := nil |}).

End CC.

Definition foldi {A B} (f : N -> A -> B -> B) (xs : list A) (b0 : B) : B :=
  let fix _foldi (n : N) (xs : list A) :=
    match xs with
    | x :: xs => f n x (_foldi (N.succ n) xs)
    | nil => b0
    end in _foldi 0 xs.

Definition map_of_grid (xs : list (list N)) : set (N * N) :=
  foldi (fun i =>
    foldi (fun j h m => if h <? 9 then insert_set (i, j) m else m))
    xs empty.

Fixpoint map_filter {A B} (f : A -> option B) (xs : list A) : list B :=
  match xs with
  | [] => []
  | x :: xs =>
    match f x with
    | None => map_filter f xs
    | Some y => y :: map_filter f xs
    end
  end.

Definition fourneighbors (m : set (N * N)) '((i,j) : N * N) : list (N * N) :=
  filter (fun x => elem_set x m) [(i+1,j);(i-1,j);(i,j+1);(i,j-1)].

(* Assumes padding on the sides *)
Definition graph_of_map (m : set (N * N)) : graph (N * N) :=
  {| nodes := elements (dom (gset _) m)
  ;  neighbors := fourneighbors m
  |}.

Definition graph_of_grid (m : list (list N)) : graph (N * N) :=
  graph_of_map (map_of_grid (pad m)).

(* Compute connected_components (graph_of_grid example). *)

Definition solve2 (m : Input) : N :=
  let ccs := connected_components (graph_of_grid m) in
  let sizes := merge_sort N.ge (map (fun cc => N.of_nat (length cc)) ccs) in
  match sizes with
  | a :: b :: c :: _ => a * b * c
  | _ => 0
  end.

(* Compute solve2 example. *)

Definition solve12 (xs : Input) : N * N := (solve xs, solve2 xs).


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

(** Euclidean Division *)

Require Import NAxioms NProperties NZDiv.

Module Type NDivSpecific (Import N : NAxiomsSig')(Import DM : DivMod' N).
 Axiom mod_upper_bound : forall a b, b ~= 0 -> a mod b < b.
End NDivSpecific.

Module Type NDivSig := NAxiomsSig <+ DivMod <+ NZDivCommon <+ NDivSpecific.
Module Type NDivSig' := NAxiomsSig' <+ DivMod' <+ NZDivCommon <+ NDivSpecific.

Module NDivPropFunct (Import N : NDivSig')(Import NP : NPropSig N).

(** We benefit from what already exists for NZ *)

 Module ND <: NZDiv N.
  Definition div := div.
  Definition modulo := modulo.
  Definition div_wd := div_wd.
  Definition mod_wd := mod_wd.
  Definition div_mod := div_mod.
  Lemma mod_bound : forall a b, 0<=a -> 0<b -> 0 <= a mod b < b.
  Proof. split. apply le_0_l. apply mod_upper_bound. order. Qed.
 End ND.
 Module Import NZDivP := NZDivPropFunct N NP ND.

 Ltac auto' := try rewrite <- neq_0_lt_0; auto using le_0_l.

(** Let's now state again theorems, but without useless hypothesis. *)

(** Uniqueness theorems *)

Theorem div_mod_unique :
 forall b q1 q2 r1 r2, r1<b -> r2<b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof. intros. apply div_mod_unique with b; auto'. Qed.

Theorem div_unique:
 forall a b q r, r<b -> a == b*q + r -> q == a/b.
Proof. intros; apply div_unique with r; auto'. Qed.

Theorem mod_unique:
 forall a b q r, r<b -> a == b*q + r -> r == a mod b.
Proof. intros. apply mod_unique with q; auto'. Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, a~=0 -> a/a == 1.
Proof. intros. apply div_same; auto'. Qed.

Lemma mod_same : forall a, a~=0 -> a mod a == 0.
Proof. intros. apply mod_same; auto'. Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, a<b -> a/b == 0.
Proof. intros. apply div_small; auto'. Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, a<b -> a mod b == a.
Proof. intros. apply mod_small; auto'. Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
Proof. intros. apply div_0_l; auto'. Qed.

Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
Proof. intros. apply mod_0_l; auto'. Qed.

Lemma div_1_r: forall a, a/1 == a.
Proof. intros. apply div_1_r; auto'. Qed.

Lemma mod_1_r: forall a, a mod 1 == 0.
Proof. intros. apply mod_1_r; auto'. Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. exact div_1_l. Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. exact mod_1_l. Qed.

Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
Proof. intros. apply div_mul; auto'. Qed.

Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
Proof. intros. apply mod_mul; auto'. Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, b~=0 -> a mod b <= a.
Proof. intros. apply mod_le; auto'. Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. exact div_str_pos. Qed.

Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> a<b).
Proof. intros. apply div_small_iff; auto'. Qed.

Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> a<b).
Proof. intros. apply mod_small_iff; auto'. Qed.

Lemma div_str_pos_iff : forall a b, b~=0 -> (0<a/b <-> b<=a).
Proof. intros. apply div_str_pos_iff; auto'. Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. exact div_lt. Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, c~=0 -> a<=b -> a/c <= b/c.
Proof. intros. apply div_le_mono; auto'. Qed.

Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
Proof. intros. apply mul_div_le; auto'. Qed.

Lemma mul_succ_div_gt: forall a b, b~=0 -> a < b*(S (a/b)).
Proof. intros; apply mul_succ_div_gt; auto'. Qed.

(** The previous inequality is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
Proof. intros. apply div_exact; auto'. Qed.

(** Some additionnal inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, b~=0 -> a < b*q -> a/b < q.
Proof. intros. apply div_lt_upper_bound; auto'. Qed.

Theorem div_le_upper_bound:
  forall a b q, b~=0 -> a <= b*q -> a/b <= q.
Proof. intros; apply div_le_upper_bound; auto'. Qed.

Theorem div_le_lower_bound:
  forall a b q, b~=0 -> b*q <= a -> q <= a/b.
Proof. intros; apply div_le_lower_bound; auto'. Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<q<=r -> p/r <= p/q.
Proof. intros. apply div_le_compat_l. auto'. auto. Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, c~=0 ->
 (a + b * c) mod c == a mod c.
Proof. intros. apply mod_add; auto'. Qed.

Lemma div_add : forall a b c, c~=0 ->
 (a + b * c) / c == a / c + b.
Proof. intros. apply div_add; auto'. Qed.

Lemma div_add_l: forall a b c, b~=0 ->
 (a * b + c) / b == a + c / b.
Proof. intros. apply div_add_l; auto'. Qed.

(** Cancellations. *)

Lemma div_mul_cancel_r : forall a b c, b~=0 -> c~=0 ->
 (a*c)/(b*c) == a/b.
Proof. intros. apply div_mul_cancel_r; auto'. Qed.

Lemma div_mul_cancel_l : forall a b c, b~=0 -> c~=0 ->
 (c*a)/(c*b) == a/b.
Proof. intros. apply div_mul_cancel_l; auto'. Qed.

Lemma mul_mod_distr_r: forall a b c, b~=0 -> c~=0 ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof. intros. apply mul_mod_distr_r; auto'. Qed.

Lemma mul_mod_distr_l: forall a b c, b~=0 -> c~=0 ->
  (c*a) mod (c*b) == c * (a mod b).
Proof. intros. apply mul_mod_distr_l; auto'. Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, n~=0 ->
 (a mod n) mod n == a mod n.
Proof. intros. apply mod_mod; auto'. Qed.

Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof. intros. apply mul_mod_idemp_l; auto'. Qed.

Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof. intros. apply mul_mod_idemp_r; auto'. Qed.

Theorem mul_mod: forall a b n, n~=0 ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof. intros. apply mul_mod; auto'. Qed.

Lemma add_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof. intros. apply add_mod_idemp_l; auto'. Qed.

Lemma add_mod_idemp_r : forall a b n, n~=0 ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof. intros. apply add_mod_idemp_r; auto'. Qed.

Theorem add_mod: forall a b n, n~=0 ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof. intros. apply add_mod; auto'. Qed.

Lemma div_div : forall a b c, b~=0 -> c~=0 ->
 (a/b)/c == a/(b*c).
Proof. intros. apply div_div; auto'. Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, b~=0 -> c*(a/b) <= (c*a)/b.
Proof. intros. apply div_mul_le; auto'. Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, b~=0 ->
 (a mod b == 0 <-> exists c, a == b*c).
Proof. intros. apply mod_divides; auto'. Qed.

End NDivPropFunct.


(**
  [TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Cats_Standalone]

  Part of the [TypeTheory] library (Ahrens, Lumsdaine, Voevodsky, 2015–present).
*)

(**

This file defines the categories of term-structures and _q_-morphism structures over a fixed object-extension structure, and proves that they are univalent and equivalent.

For the more interesting case where the object-extension structure is also allowed to vary, see [CwF_Split_TypeCat_Cats], where this more general category is constructed, using the formalism of displayed categories, and [CwF_SplitTypeCat_Equiv_Cats], giving the equivalence in the displayed setting.

In general, this file should be deprecated, and the displayed version should be used for all further development.  This standalone version is included just to give the equivalence in a form independent of the development of displayed categories.

Main definitions:

- [term_fun_precategory]
- [qq_structure_precategory]
- category of compatible pairs
- projection functors from compatible pairs to structures
- proof that those projection functors are split and ff

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.

Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Defs.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Maps.
Require Import TypeTheory.CwF_TypeCat.CwF_SplitTypeCat_Equivalence.

(** Some local notations, *)

Local Notation "Γ ◂ A" := (comp_ext _ Γ A) (at level 30).
Local Notation "'Ty'" := (fun X Γ => TY X $p Γ) (at level 10).
Local Notation "'Tm'" := (fun Y Γ => TM Y $p Γ) (at level 10).

Local Notation Δ := comp_ext_compare.

Section fix_cat_obj_ext.

Variable C : category.
Variable X : obj_ext_structure C.

(** * category of term-structures *)
Section Term_Fun_Structure_Precat.

Definition term_fun_mor
    (Y Y' : term_fun_structure C X)
  : UU
:= ∑ FF_TM : TM Y --> TM Y',
       FF_TM ;; pp Y' = pp Y
     ×
       ∏ {Γ:C} {A : Ty X Γ},
           FF_TM $nt (te Y A) = te Y' _.

Definition term_fun_mor_TM {Y Y'} (FF : term_fun_mor Y Y')
  : _ --> _
:= pr1 FF.

Definition term_fun_mor_pp {Y Y'} (FF : term_fun_mor Y Y')
  : term_fun_mor_TM FF ;; pp Y' = pp Y
:= pr1 (pr2 FF).

Definition term_fun_mor_te {Y Y'} (FF : term_fun_mor Y Y')
    {Γ:C} (A : Ty X Γ)
  : term_fun_mor_TM FF $nt (te Y A) = (te Y' _)
:= pr2 (pr2 FF) Γ A.

Definition term_fun_mor_Q {Y Y'} (FF : term_fun_mor Y Y')
    {Γ:C} (A : Ty X Γ)
  : Q Y A ;; term_fun_mor_TM FF = Q Y' _.
Proof.
  apply nat_trans_eq. apply homset_property.
  intros Γ'; simpl in Γ'.
  unfold yoneda_objects_ob. apply funextsec; intros f.
  etrans. apply nat_trans_ax_pshf.
  cbn. apply maponpaths, term_fun_mor_te.
Qed.

(* Defined only locally, since once [isaprop_term_fun_mor_eq] is defined, that should always be used in place of this. *)
Local Lemma term_fun_mor_eq {Y} {Y'} (FF FF' : term_fun_mor Y Y')
    (e_TM : ∏ Γ (t : Tm Y Γ),
      term_fun_mor_TM FF $nt t
      = term_fun_mor_TM FF' $nt t)
  : FF = FF'.
Proof.
  apply subtypePath.
  - intros x; apply isapropdirprod.
    + apply homset_property.
    + repeat (apply impred_isaprop; intro). apply setproperty.
  - apply nat_trans_eq. apply has_homsets_HSET.
    intros Γ. apply funextsec. unfold homot. apply e_TM.
Qed.

(* This is not full naturality of [term_to_section]; it is just what is required for [isaprop_term_fun_mor] below. *)
Lemma term_to_section_naturality {Y} {Y'}
  {FY : term_fun_mor Y Y'}
  {Γ : C} (t : Tm Y Γ) (A := pp Y $nt t)
  : pr1 (term_to_section (term_fun_mor_TM FY $nt t))
  = pr1 (term_to_section t)
   ;; Δ (!nat_trans_eq_pointwise_pshf (term_fun_mor_pp FY) _).
Proof.
  set (t' := term_fun_mor_TM FY $nt t).
  set (A' := pp Y' $nt t').
  set (Pb := isPullback_preShv_to_pointwise (isPullback_Q_pp Y' A') Γ);
    simpl in Pb.
  apply (pullback_HSET_elements_unique Pb); clear Pb.
  - unfold yoneda_morphisms_data; cbn.
    etrans. use (pr2 (term_to_section t')). apply pathsinv0.
    etrans. 2: { refine (pr2 (term_to_section t)). }
    etrans. apply @pathsinv0, assoc.
    apply maponpaths.
    apply comp_ext_compare_π.
  - etrans. apply term_to_section_recover.
    apply pathsinv0.
    etrans. apply Q_comp_ext_compare.
    etrans.
      eapply pathsinv0, nat_trans_eq_pointwise_pshf, term_fun_mor_Q.
    cbn. apply maponpaths, term_to_section_recover.
Qed.

Lemma term_fun_mor_recover_term  {Y} {Y'}
  {FY : term_fun_mor Y Y'}
  {Γ : C} (t : Tm Y Γ)
  : term_fun_mor_TM FY $nt t
  = Q Y' _ $nt (pr1 (term_to_section t) ).
Proof.
  etrans. apply @pathsinv0, term_to_section_recover.
  etrans. apply maponpaths, term_to_section_naturality.
  apply Q_comp_ext_compare.
Qed.

Lemma isaprop_term_fun_mor {Y} {Y'}
  : isaprop (term_fun_mor Y Y').
Proof.
  apply invproofirrelevance; intros FF FF'. apply term_fun_mor_eq.
  intros Γ t.
  etrans. apply term_fun_mor_recover_term.
  apply @pathsinv0. apply term_fun_mor_recover_term.
Qed.

Definition term_fun_ob_mor : precategory_ob_mor.
Proof.
  exists (term_fun_structure C X).
  exact @term_fun_mor.
Defined.

Definition term_fun_id_comp : precategory_id_comp term_fun_ob_mor.
Proof.
  apply tpair.
  - intros Y. simpl; unfold term_fun_mor.
    exists (identity _). apply tpair.
    + apply id_left.
    + intros Γ A. apply idpath.
  - intros Y0 Y1 Y2 FF GG.
    exists (term_fun_mor_TM FF ;; term_fun_mor_TM GG). apply tpair.
    + etrans. apply @pathsinv0. apply assoc.
      etrans. apply maponpaths, term_fun_mor_pp.
      apply term_fun_mor_pp.
    + intros Γ A.
      etrans. cbn. apply maponpaths, term_fun_mor_te.
      apply term_fun_mor_te.
Defined.

Definition term_fun_data : precategory_data
  := (_ ,, term_fun_id_comp).

Definition term_fun_axioms : is_precategory term_fun_data.
Proof.
  use make_is_precategory_one_assoc; intros; apply isaprop_term_fun_mor.
Qed.

Definition term_fun_precategory : precategory
  := (_ ,, term_fun_axioms).

Lemma has_homsets_term_fun_precat
  : has_homsets term_fun_precategory.
Proof.
  intros a b. apply isaset_total2.
  apply homset_property.
  intros. apply isasetaprop, isapropdirprod.
  apply homset_property.
  repeat (apply impred_isaprop; intro). apply setproperty.
Qed.

End Term_Fun_Structure_Precat.

(** * category of _q_-morphism-structures *)

Section qq_Structure_Precat.

Definition qq_structure_ob_mor : precategory_ob_mor.
Proof.
  exists (qq_morphism_structure X).
  intros Z Z'.
  use (∏ Γ' Γ (f : C ⟦ Γ' , Γ ⟧) (A : Ty X Γ), _).
  use (qq Z f A  = _).
  use (qq Z' f).
Defined.

Lemma isaprop_qq_structure_mor
  (Z Z' : qq_structure_ob_mor)
  : isaprop (Z --> Z').
Proof.
  repeat (apply impred_isaprop; intro). apply homset_property.
Qed.

Definition qq_structure_id_comp : precategory_id_comp qq_structure_ob_mor.
Proof.
  apply tpair.
  - intros Z;
    intros Γ Γ' f A. apply idpath.
  - intros Z0 Z1 Z2;
    intros FF GG Γ Γ' f A.
    etrans. apply FF. apply GG.
Qed.

Definition qq_structure_data : precategory_data
  := (_ ,, qq_structure_id_comp).

Definition qq_structure_axioms : is_precategory qq_structure_data.
Proof.
  repeat apply tpair; intros;
    try apply isasetaprop; apply isaprop_qq_structure_mor.
Qed.

Definition qq_structure_precategory : precategory
  := (_ ,, qq_structure_axioms).

End qq_Structure_Precat.

Arguments qq_structure_precategory : clear implicits.

Section Compatible_Disp_Cat.

(* TODO: rename [strucs_compat_FOO] to [strucs_iscompat_FOO] throughout, to disambiguate these from the sigma’d displayed-precat [compat_structures]. *)

Definition strucs_compat_ob_mor
  : precategory_ob_mor.
Proof.
  use tpair.
  - exact (∑ YZ : (term_fun_precategory × qq_structure_precategory),
                  iscompatible_term_qq (pr1 YZ) (pr2 YZ)).
  - intros YZ YZ'.
    exact ((pr1 (pr1 YZ)) --> (pr1 (pr1 YZ'))
           × (pr2 (pr1 YZ)) --> pr2 (pr1 YZ')).
Defined.

Definition strucs_compat_id_comp
  : precategory_id_comp strucs_compat_ob_mor.
Proof.
  split.
  - intro; split; apply identity.
  - intros a b c f g. split.
    eapply @compose. apply (pr1 f). apply (pr1 g).
    eapply @compose. apply (pr2 f). apply (pr2 g).
Defined.

Definition strucs_compat_data : precategory_data
  := ( _ ,, strucs_compat_id_comp).

Definition strucs_compat_axioms : is_precategory strucs_compat_data.
Proof.
  use make_is_precategory_one_assoc; intros.
  - apply dirprodeq; apply id_left.
  - apply dirprodeq; apply id_right.
  - apply dirprodeq; apply assoc.
Qed.

Definition compat_structures_precategory
  : precategory
:= ( _ ,, strucs_compat_axioms).

(* should this be the name of the compatible pairs category? *)
(*
Definition compat_structures_disp_cat
  := sigma_disp_cat strucs_compat_disp_cat.
*)

Definition compat_structures_pr1_functor
  : functor compat_structures_precategory term_fun_precategory.
Proof.
  use tpair.
  - use tpair.
    + exact (fun YZp => pr1 (pr1 YZp)).
    + intros a b f. apply (pr1 f).
  - use tpair.
    + intro c. apply idpath.
    + intros a b c f g. apply idpath.
Defined.

Definition compat_structures_pr2_functor
  : functor compat_structures_precategory qq_structure_precategory.
Proof.
  use tpair.
  - use tpair.
    + exact (fun YZp => pr2 (pr1 YZp)).
    + intros a b f. apply (pr2 f).
  - use tpair.
    + intro c. apply idpath.
    + intros a b c f g. apply idpath.
Defined.

End Compatible_Disp_Cat.

Section Unique_QQ_From_Term.

Lemma qq_from_term_ob (Y : term_fun_precategory)
  : ∑ (Z : qq_structure_precategory), iscompatible_term_qq Y Z.
Proof.
  exists (qq_from_term Y).
  apply iscompatible_qq_from_term.
Defined.

Lemma qq_from_term_mor
  {Y : term_fun_precategory} {Y'} (FY : Y --> Y')
  {Z : qq_structure_precategory} {Z'}
  (W : iscompatible_term_qq Y Z)
  (W' : iscompatible_term_qq Y' Z')
  : Z --> Z'.
Proof.
  intros Γ' Γ f A.
  cbn in W, W', FY. unfold iscompatible_term_qq in *.
  unfold term_fun_mor in FY.
  apply (Q_pp_Pb_unique Y'); simpl; unfold yoneda_morphisms_data.
  - etrans. apply qq_π.
    apply pathsinv0, qq_π.
  - etrans. cbn. apply maponpaths, @pathsinv0, (term_fun_mor_te FY).
    etrans. apply pathsinv0, nat_trans_ax_pshf.
    etrans. cbn. apply maponpaths, @pathsinv0, W.
    etrans. apply term_fun_mor_te.
    apply W'.
Qed.

Lemma qq_from_term_mor_unique
  {Y : term_fun_precategory} {Y'} (FY : Y --> Y')
  {Z : qq_structure_precategory} {Z'}
  (W : iscompatible_term_qq Y Z)
  (W' : iscompatible_term_qq Y' Z')
  : isaprop (Z --> Z').
Proof.
  simpl. repeat (apply impred_isaprop; intro). apply homset_property.
Qed.

End Unique_QQ_From_Term.

Section Unique_Term_From_QQ.

Lemma term_from_qq_ob (Z : qq_structure_precategory)
  : ∑ (Y : term_fun_precategory), iscompatible_term_qq Y Z.
Proof.
  exists (term_from_qq Z).
  apply iscompatible_term_from_qq.
Defined.

(** The next main goal is the following statement.  However, the construction of the morphism of term structures is rather large; so we break out the first component (the map of term presheaves) into several independent lemmas, before returning to this in [term_from_qq_mor] below. *)
Lemma term_from_qq_mor
  {Z Z' : qq_structure_precategory} (FZ : Z --> Z')
  {Y : term_fun_precategory} {Y'}
  (W : iscompatible_term_qq Y Z)
  (W' : iscompatible_term_qq Y' Z')
  : (Y --> Y').
Abort.

(* TODO: rename and upstream this section! *)
Section Rename_me.
(* TODO: naming conventions in this section clash rather with those of [CwF_TypeCat.CwF_SplitTypeCat_Equivalence]. Consider! *)
Lemma tm_from_qq_mor_data {Z Z' : qq_structure_precategory} (FZ : Z --> Z')
  : nat_trans_data (tm_from_qq Z) (tm_from_qq Z').
Proof.
  intros Γ Ase; exact Ase. (* ! *)
Defined.

Lemma tm_from_qq_mor_naturality
    {Z Z' : qq_structure_precategory} (FZ : Z --> Z')
  : is_nat_trans (tm_from_qq Z) (tm_from_qq Z') (tm_from_qq_mor_data FZ).
Proof.
  intros Γ Γ' f; cbn in Γ, Γ', f.
  apply funextsec; intros [A [s e]].
  use tm_from_qq_eq.
  - apply idpath.
  - etrans. apply id_right.
    cbn. apply PullbackArrowUnique.
    + set (XX := (make_Pullback _ (qq_π_Pb (pr1 Z) f A))).
      apply (PullbackArrow_PullbackPr1 XX).
    + cbn; cbn in FZ. etrans. apply maponpaths, @pathsinv0, FZ.
      apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
Qed.

Lemma tm_from_qq_mor_TM {Z Z' : qq_structure_precategory} (FZ : Z --> Z')
  : nat_trans (tm_from_qq Z) (tm_from_qq Z').
Proof.
  exists (tm_from_qq_mor_data FZ).
  apply tm_from_qq_mor_naturality.
Defined.

Lemma tm_from_qq_mor_pp {Z Z' : qq_structure_precategory} (FZ : Z --> Z')
  : (tm_from_qq_mor_TM FZ : preShv C ⟦ _ , _ ⟧) ;; pp_from_qq Z'
  = pp_from_qq Z.
Proof.
  apply nat_trans_eq. apply homset_property.
  intros Γ. apply idpath.
Qed.

Lemma tm_from_qq_mor_te {Z Z' : qq_structure_precategory} (FZ : Z --> Z')
    {Γ} (A : Ty X Γ)
  : tm_from_qq_mor_TM FZ _ (te_from_qq Z A) = (te_from_qq Z' A).
Proof.
  cbn.
  use tm_from_qq_eq.
  - apply idpath.
  - etrans. apply id_right.
    cbn. apply PullbackArrowUnique.
    + cbn. apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
    + cbn. cbn in FZ.
      etrans. apply maponpaths, @pathsinv0, FZ.
      apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
Qed.

End Rename_me.

Definition term_from_qq_mor_TM
    {Z : qq_structure_precategory} {Z'} (FZ : Z --> Z')
    {Y : term_fun_precategory} {Y'}
    (W : iscompatible_term_qq Y Z)
    (W' : iscompatible_term_qq Y' Z')
  : TM (Y : term_fun_structure _ _) --> TM (Y' : term_fun_structure _ _).
Proof.
  use ( _ ;; (tm_from_qq_mor_TM FZ : preShv C ⟦ _ , _ ⟧) ;; _).
  - exact (given_TM_to_canonical _ _ (Y,,W)).
  - exact (canonical_TM_to_given _ _ (Y',,W')).
Defined.

Lemma term_from_qq_mor
  {Z : qq_structure_precategory} {Z'} (FZ : Z --> Z')
  {Y : term_fun_precategory} {Y'}
  (W : iscompatible_term_qq Y Z)
  (W' : iscompatible_term_qq Y' Z')
  : (Y --> Y').
Proof.
  simpl in W, W'; unfold iscompatible_term_qq in W, W'. (* Readability *)
  simpl in Y, Y'.  (* To avoid needing casts [Y : term_fun_structure _]. *)
  simpl; unfold term_fun_mor.
  exists (term_from_qq_mor_TM FZ W W').
  apply make_dirprod; try intros Γ A.
  - etrans. apply @pathsinv0, assoc.
    etrans. apply maponpaths, (pp_canonical_TM_to_given _ _ (_,,_)).
    etrans. apply @pathsinv0, assoc.
    etrans. apply maponpaths, tm_from_qq_mor_pp.
    apply (pp_given_TM_to_canonical _ _ (_,,_)).
  - unfold term_from_qq_mor_TM.
    cbn.
    etrans. apply maponpaths, (given_TM_to_canonical_te _ _ (_,,W)).
    etrans. apply maponpaths, (tm_from_qq_mor_te FZ).
    apply (canonical_TM_to_given_te _ _ (_,,_)).
Qed.

Lemma term_from_qq_mor_unique
  {Z : qq_structure_precategory} {Z'} (FZ : Z --> Z')
  {Y : term_fun_precategory} {Y'}
  (W : iscompatible_term_qq Y Z)
  (W' : iscompatible_term_qq Y' Z')
  : isaprop ( Y --> Y').
Proof.
  simpl. apply isaprop_term_fun_mor.
Defined.

End Unique_Term_From_QQ.

Section Strucs_Equiv_Precats.

Lemma compat_structures_pr1_split_ess_surj
  : split_ess_surj (compat_structures_pr1_functor).
Proof.
  intro Y.
  exists (((Y,, qq_from_term Y)),,iscompatible_qq_from_term Y).
  apply identity_z_iso.
Defined.

Lemma compat_structures_pr1_fully_faithful
  : fully_faithful (compat_structures_pr1_functor).
Proof.
  intros YZW YZW'.
  destruct YZW as [  [Y Z]  W].
  destruct YZW' as [ [Y' Z']  W'].
  unfold compat_structures_pr1_functor; simpl.
  use gradth.
  - intro f. exists f. use (qq_from_term_mor f W W').
  - intros. cbn. destruct x as [f q]. cbn.
    apply maponpaths.
    apply proofirrelevance.
    use (qq_from_term_mor_unique f); assumption.
  - intros y. cbn. apply idpath.
Qed.

Lemma compat_structures_pr2_split_ess_surj
  : split_ess_surj (compat_structures_pr2_functor).
Proof.
  intros Z.
  exists (((term_from_qq Z,, Z)),,iscompatible_term_from_qq Z).
  apply identity_z_iso.
Defined.

Lemma compat_structures_pr2_fully_faithful
  : fully_faithful (compat_structures_pr2_functor).
Proof.
  intros YZW YZW';
  destruct YZW as [  [Y Z]  W];
  destruct YZW' as [  [Y' Z']  W'].
  unfold compat_structures_pr2_functor; simpl.
  use gradth.
  - intro x.
    exists (term_from_qq_mor x W W').
    exact x.
  - intro r. cbn.
    destruct r as [r1 r2]. apply maponpaths_2.
    apply proofirrelevance.
    use (term_from_qq_mor_unique r2); assumption.
  - intros. apply idpath.
Qed.

End Strucs_Equiv_Precats.

Section Is_Univalent_Families_Strucs.

Definition iso_to_TM_eq
  (Y Y' : term_fun_precategory)
  : z_iso Y Y'
  -> TM (Y : term_fun_structure _ X) = TM (Y' : term_fun_structure _ X).
Proof.
  intro i.
  use isotoid.
  - apply univalent_category_is_univalent.
  - exists (term_fun_mor_TM (i : _ --> _)).
    exists (term_fun_mor_TM (inv_from_z_iso i)).
    split.
    + exact (maponpaths term_fun_mor_TM (z_iso_inv_after_z_iso i)).
    + exact (maponpaths term_fun_mor_TM (z_iso_after_z_iso_inv i)).
Defined.

Lemma prewhisker_iso_to_TM_eq
  {Y Y' : term_fun_precategory}
  (FG : z_iso Y Y')
  {P : preShv C} (α : TM (Y : term_fun_structure _ X) --> P)
: transportf (λ P' : preShv C, P' --> P) (iso_to_TM_eq  _ _ FG) α
  = term_fun_mor_TM (inv_from_z_iso FG) ;; α.
Proof.
  etrans. apply transportf_isotoid.
  apply maponpaths_2.
  apply inv_from_z_iso_from_is_z_iso.
Qed.

Lemma postwhisker_iso_to_TM_eq
  {Y Y' : term_fun_precategory}
  (FG : z_iso Y Y')
  {P : preShv C} (α : P --> TM (Y : term_fun_structure _ X))
: transportf (λ P' : preShv C, P --> P') (iso_to_TM_eq _ _ FG) α
  = α ;; term_fun_mor_TM (pr1 FG).
Proof.
  use postwhisker_isotoid.
Qed.

Lemma idtoiso_iso_to_TM_eq
  {Y Y' : term_fun_precategory}
  (FG : z_iso Y Y')
: (idtoiso (iso_to_TM_eq _ _ FG) : _ --> _)
  = term_fun_mor_TM (FG : _ --> _).
Proof.
  use (maponpaths pr1 (idtoiso_isotoid _ _ _ _ _)).
Qed.

Definition iso_to_id_term_fun_precategory
  (Y Y' : term_fun_precategory)
  : z_iso Y Y' -> Y = Y'.
Proof.
  intros i.
  apply subtypePath. { intro. apply isaprop_term_fun_structure_axioms. }
  apply total2_paths_f with (iso_to_TM_eq _ _ i).
  rewrite transportf_dirprod.
  apply dirprodeq.
  - etrans. apply prewhisker_iso_to_TM_eq.
    apply term_fun_mor_pp.
  - etrans. use transportf_forall.
    apply funextsec; intros Γ.
    etrans. use transportf_forall.
    apply funextsec; intros A.
    etrans. apply transportf_pshf.
    etrans.
      refine (toforallpaths _ (te _ _)).
      refine (toforallpaths _ _).
      apply maponpaths, idtoiso_iso_to_TM_eq.
    apply term_fun_mor_te.
Qed.

Lemma has_homsets_term_fun_precategory
  : has_homsets term_fun_precategory.
Proof.
  intros a b.
  apply isaset_total2.
  apply homset_property.
  intros. apply isasetaprop, isapropdirprod.
  apply homset_property.
  repeat (apply impred_isaprop; intro). apply setproperty.
Qed.

Definition term_fun_category : category
  := make_category _ has_homsets_term_fun_precategory.

Theorem is_univalent_term_fun_structure
  : is_univalent term_fun_category.
Proof.
  use eq_equiv_from_retraction.
  - apply iso_to_id_term_fun_precategory.
  - intros. apply z_iso_eq. apply isaprop_term_fun_mor.
Qed.

End Is_Univalent_Families_Strucs.

Section Is_Univalent_qq_Strucs.

Lemma isaset_qq_morphism_structure (x : obj_ext_structure C)
  : isaset (qq_morphism_structure x).
Proof.
  apply (isofhleveltotal2 2).
  - apply (isofhleveltotal2 2).
    + do 4 (apply impred; intro).
      apply homset_property.
    + intros. do 4 (apply impred; intro).
      apply (isofhleveltotal2 2).
      * apply hlevelntosn.
        apply homset_property.
      * intro. apply hlevelntosn.
        apply pullbacks.isaprop_isPullback.
  - intro d. unfold qq_morphism_axioms.
    apply isofhleveldirprod.
    + do 2 (apply impred; intro).
      apply hlevelntosn.
      apply homset_property.
    + do 6 (apply impred; intro).
      apply hlevelntosn.
      apply homset_property.
Qed.

Lemma has_homsets_qq_structure_precategory
  : has_homsets qq_structure_precategory.
Proof.
  intros a b. apply isasetaprop. apply isaprop_qq_structure_mor.
Qed.

Definition qq_structure_category : category
  := make_category _ has_homsets_qq_structure_precategory.

Lemma isaprop_iso_qq_morphism_structure
  (d d' : qq_structure_category)
  : isaprop (z_iso d d').
Proof.
  apply (isofhleveltotal2 1).
  - do 4 (apply impred; intro).
    apply homset_property.
  - intro. apply isaprop_is_z_isomorphism.
Qed.

Lemma qq_structure_eq
  (x : obj_ext_structure C)
  (d d' : qq_morphism_structure x)
  (H : ∏ (Γ Γ' : C) (f : Γ' --> Γ) (A : Ty x Γ),
           qq d f A = qq d' f A)
  : d = d'.
Proof.
  apply subtypePath.
  { intro. apply isaprop_qq_morphism_axioms. }
  apply subtypePath.
  { intro. do 4 (apply impred; intro).
           apply isofhleveltotal2.
     + apply homset_property.
     + intro. apply pullbacks.isaprop_isPullback.
  }
  do 4 (apply funextsec; intro).
  apply H.
Defined.

Definition qq_structure_iso_to_id
  (d d' : qq_structure_precategory)
  : z_iso d d' → d = d'.
Proof.
  intro H.
  apply qq_structure_eq.
  intros Γ Γ' f A.
  use (pr1 H).
Defined.

Theorem is_univalent_qq_morphism
  : is_univalent qq_structure_category.
Proof.
  intros d d'.
  use isweqimplimpl.
  + apply qq_structure_iso_to_id.
  + apply isaset_qq_morphism_structure.
  + apply isaprop_iso_qq_morphism_structure.
Qed.

End Is_Univalent_qq_Strucs.

Lemma has_homsets_compat_structures_precategory
  : has_homsets compat_structures_precategory.
Proof.
  intros a b.
  apply isasetdirprod.
  - apply has_homsets_term_fun_precategory.
  - apply has_homsets_qq_structure_precategory.
Qed.

Definition compat_structures_category : category
  := make_category _ has_homsets_compat_structures_precategory.

Definition pr1_equiv : @adj_equivalence_of_cats
                         compat_structures_category
                         term_fun_category
                         compat_structures_pr1_functor.
Proof.
  use adj_equivalence_of_cats_ff_split.
  - apply compat_structures_pr1_fully_faithful.
  - apply compat_structures_pr1_split_ess_surj.
Defined.

Definition pr2_equiv : @adj_equivalence_of_cats
                         compat_structures_category
                         qq_structure_category
                         compat_structures_pr2_functor.
Proof.
  use adj_equivalence_of_cats_ff_split.
  - apply compat_structures_pr2_fully_faithful.
  - apply compat_structures_pr2_split_ess_surj.
Defined.

Definition pr1_equiv_inv : adj_equivalence_of_cats (right_adjoint pr1_equiv).
Proof.
  use adj_equivalence_of_cats_inv.
Defined.

Definition equiv_of_structures : adj_equivalence_of_cats _
  := @comp_adj_equivalence_of_cats _ _ _ _ _
                                      pr1_equiv_inv pr2_equiv.

Definition equiv_of_types_of_structures
  : term_fun_precategory ≃ qq_structure_precategory.
Proof.
  use (weq_on_objects_from_adj_equiv_of_cats _ _
           is_univalent_term_fun_structure
           is_univalent_qq_morphism
           _
           equiv_of_structures).
Defined.

Lemma equiv_of_types_equal_direct_constr
  : equiv_of_types_of_structures ~ weq_term_qq X.
Proof.
  intro Y.
  apply idpath.
Defined.

(* Print Assumptions equiv_of_types_equal_direct_constr. *)

End fix_cat_obj_ext.


(*|
#################################
Coq: cannot unify inductive types
#################################

:Link: https://stackoverflow.com/q/50883392
|*)

(*|
Question
********

I am trying to represent multi-dimensional arrays as restricted
functions, and I am having a trouble with defining what seem to be a
primitive function.

Here are the definitions:
|*)

Require Export Fin.
Require Export PeanoNat.

Inductive ispace : nat -> Type :=
  Rect: forall d : nat, (Fin.t d -> nat) -> ispace d.

Inductive index : nat -> Type :=
  Idx: forall d : nat, (Fin.t d -> nat) -> index d.

Inductive bound_idx : forall d, index d -> ispace d -> Prop -> Type :=
  RectBoundIdx : forall d f_idx f_shp,
    bound_idx d (Idx d f_idx)
              (Rect d f_shp)
              (forall i, f_idx i < f_shp i).

Inductive array :
  forall d (is : ispace d),
    (forall idx pf, bound_idx d idx is pf -> nat) -> Type :=
  RectArray: forall (d:nat) sh_f val_f, array d (Rect d sh_f) val_f.

(*|
I define type families for rectangular index-spaces, for indices and
for an index that is bounded by a rectangular index-space. The array
type is a function from a restricted index-space to ``nat``.

Now, I am trying to construct an array from such a function, and Coq
tells me:
|*)

Fail Definition func_to_arr d is
                (af : forall idx pf, bound_idx d idx is pf -> nat) :=
       match is with
       | Rect d f => RectArray d f af
       end. (* .fails .unfold *)

(*|
So I am wondering, how can I pass this information to the above
definition, so that it becomes valid. Unless I misunderstand
something, the type of af contains all the necessary information to
reconstruct an array.
|*)

(*|
Answer
******

This issue is very common in dependently-typed programming with Coq.
To solve it, people usually use the *convoy pattern* described in
`CPDT <http://adam.chlipala.net/cpdt/>`__ by A. Chlipala (MoreDep
chapter, IIRC) and mentioned multiple time on Stackoverflow.

Here is how you can define the function.
|*)

Definition func_to_arr d is
           (af : forall idx pf, bound_idx d idx is pf -> nat) :=
  match is as is' in (ispace d1)
        return
        forall af' : forall idx pf,
            bound_idx d1 idx is' pf -> nat, array d1 is' af'
  with
  | Rect d2 f => fun af' => RectArray d2 f af'
  end af.

(*|
I'm doing dependent pattern-matching here, basically performing
"rewrites" of indices so Coq can see the connections between variables
that a human reader ususally takes for granted. You can read about the
constructions I used here in `extended pattern matching
<https://coq.inria.fr/refman/addendum/extended-pattern-matching.html#matching-objects-of-dependent-types>`__
section of the manual.

Incidentally, if you made ``d`` a *parameter* of your inductive types
instead of making it an *index*, you would not need to mess with
``d1``, ``d2`` and the ``in (ispace d1)`` would not be necessary. If
the choice was accidental, then you might want to take a look at the
`answer explaining the difference between those
<https://stackoverflow.com/questions/24600256/difference-between-type-parameters-and-indices/24601292#24601292>`__.
|*)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Undecidability.Synthetic.Definitions.

From Undecidability.Shared.Libs.DLW
  Require Import utils list_bool pos vec subcode sss.

From Undecidability.StackMachines
  Require Import bsm_defs.

From Undecidability.MinskyMachines.MM
  Require Import mm_defs mm_utils mm_comp.

Local Notation "P '/BSM/' s ↓" := (sss_terminates (@bsm_sss _) P s) (at level 70, no associativity).
Local Notation "P '/MM/' s ~~> t" := (sss_output (@mm_sss _) P s t) (at level 70, no associativity).

Section BSM_MM_HALTS_ON_ZERO.

  Let f : BSM_PROBLEM -> MM_PROBLEM.
  Proof.
    intros (n & i & P & v).
    destruct (bsm_mm_compiler_2 i P) as (Q & _).
    exists (2+n), Q.
    exact (bsm_state_enc v).
  Defined.

  Theorem BSM_MM_HALTS_ON_ZERO : Halt_BSM ⪯ MM_HALTS_ON_ZERO.
  Proof.
    exists f. red.
    setoid_rewrite Halt_BSM_iff.
    intros (n & i & P & v); simpl.
    destruct (bsm_mm_compiler_2 i P) as (Q & H); simpl; auto.
  Qed.

End BSM_MM_HALTS_ON_ZERO.

Section BSM_MM_HALTING.

  Let f : BSM_PROBLEM -> MM_PROBLEM.
  Proof.
    intros (n & i & P & v).
    destruct (bsm_mm_compiler_1 i P) as (Q & _).
    exists (2+n), Q.
    exact (bsm_state_enc v).
  Defined.

  Theorem BSM_MM_HALTING : Halt_BSM ⪯ Halt_MM.
  Proof.
    exists f. red.
    setoid_rewrite Halt_BSM_iff.
    setoid_rewrite Halt_MM_iff.
    intros (n & i & P & v); simpl.
    destruct (bsm_mm_compiler_1 i P) as (Q & H); simpl; auto.
  Qed.

End BSM_MM_HALTING.


From LibHyps Require Export LibHyps.
Require Export MoreLibHyps.

(*  move to experimental file (not to export *)

Require Import List.
Import ListNotations.
#[local] Open Scope autonaming_scope.

Ltac rename_hyp n th ::= rename_short n th.

Goal forall n p , n <= p -> forall q, p <= q -> n <= q.
induction 1  /n.
- intros; assumption.
- intros /n.  apply h_all_le_n_; transitivity (S m); auto.
Qed.

Goal forall n p , n <= p -> forall q, p <= q -> n <= q.
  intros * H; elim H.
  - intros /n.  assumption.
  - intros /n.  apply h_all_le_n_; transitivity (S m); auto.
Qed.

Require Import Arith.
Parameters f g h : nat -> nat.
Parameter P : nat->nat->nat-> Prop.
Goal forall x y ,  f (g (h x)) = h (g (f y)) -> x = y -> x < y ->
                   P  x y x  -> f y <> f x.
  intros x y H H0 H1 H2 /n. subst y.
  absurd (x < x) ; trivial.
  apply Nat.lt_irrefl.
Qed.


Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.ReducibilityFacts.
Require Import Undecidability.MinskyMachines.MM2. (* MM2_HALTING *)
Require Import Undecidability.StackMachines.BSM. (* BSM_HALTING *)

Require Undecidability.MinskyMachines.Reductions.BSM_MM.
Require Undecidability.FRACTRAN.Reductions.MM_FRACTRAN.
Require Undecidability.MinskyMachines.Reductions.FRACTRAN_to_MMA2.
Require Undecidability.MinskyMachines.Reductions.MMA2_to_MM2.

Theorem reduction : Halt_BSM ⪯ MM2_HALTING.
Proof.
  apply (reduces_transitive BSM_MM.BSM_MM_HALTING).
  apply (reduces_transitive MM_FRACTRAN.MM_FRACTRAN_REG_HALTING).
  apply (reduces_transitive FRACTRAN_to_MMA2.FRACTRAN_REG_MMA2_HALTING).
  exact MMA2_to_MM2.MMA2_MM2_HALTING.
Qed.


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

 Image factorization of enriched categories

 Enriched functors between enriched categories can be factorized into
 a essentially surjective functor followed by a enriched fully faithful
 functor.

 Contents
 1. The enriched image
 2. The factorization functors
 3. The commutation

 **********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.EnrichedCats.Examples.FullSubEnriched.
Require Import UniMath.CategoryTheory.Monoidal.Categories.

Local Open Scope cat.
Local Open Scope moncat.

Section ImageEnriched.
  Context {V : monoidal_cat}
          {C₁ C₂ : category}
          {E₁ : enrichment C₁ V}
          {E₂ : enrichment C₂ V}
          {F : C₁ ⟶ C₂}
          (EF : functor_enrichment F E₁ E₂).

  (**
   1. The enriched image
   *)
  Definition image_enrichment
    : enrichment (full_img_sub_precategory F) V
    := fullsub_enrichment V E₂ _.

  (**
   2. The factorization functors
   *)
  Definition image_incl_enrichment
    : functor_enrichment
        (sub_precategory_inclusion _ _)
        image_enrichment
        E₂
    := fullsub_inclusion_enrichment V E₂ _.

  Definition image_incl_enrichment_fully_faithful
    : fully_faithful_enriched_functor
        image_incl_enrichment
    := fullsub_inclusion_enrichment_fully_faithful V E₂ _.

  Definition image_proj_enrichment
    : functor_enrichment
        (functor_full_img _)
        E₁
        image_enrichment.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (λ x y, EF x y).
    - abstract
        (intro x ; cbn ;
         exact (functor_enrichment_id EF x)).
    - abstract
        (intros x y z ; cbn ;
         exact (functor_enrichment_comp EF x y z)).
    - abstract
        (intros x y f ;
         exact (functor_enrichment_from_arr EF f)).
  Defined.

  (**
   3. The commutation
   *)
  Definition image_factorization_enriched_commutes
    : nat_trans_enrichment
        (full_image_inclusion_commute_nat_iso F)
        (functor_comp_enrichment
           image_proj_enrichment
           image_incl_enrichment)
        EF.
  Proof.
    intros x y ; cbn.
    rewrite !enriched_from_arr_id.
    rewrite tensor_comp_l_id_l.
    rewrite !assoc'.
    rewrite <- enrichment_id_left.
    rewrite tensor_lunitor.
    rewrite !assoc.
    rewrite tensor_split'.
    rewrite !assoc'.
    rewrite <- enrichment_id_right.
    rewrite tensor_runitor.
    rewrite !assoc.
    apply maponpaths_2.
    refine (_ @ !(mon_linvunitor_lunitor _)).
    apply mon_rinvunitor_runitor.
  Qed.

  Definition image_factorization_enriched_commutes_inv
    : nat_trans_enrichment
        (nat_z_iso_inv (full_image_inclusion_commute_nat_iso F))
        EF
        (functor_comp_enrichment
           image_proj_enrichment
           image_incl_enrichment).
  Proof.
    intros x y ; cbn.
    rewrite !enriched_from_arr_id.
    rewrite tensor_comp_r_id_l.
    rewrite !assoc'.
    rewrite <- enrichment_id_right.
    rewrite tensor_runitor.
    rewrite !assoc.
    rewrite tensor_split.
    rewrite !assoc'.
    rewrite <- enrichment_id_left.
    rewrite tensor_lunitor.
    rewrite !assoc.
    apply maponpaths_2.
    refine (_ @ !(mon_linvunitor_lunitor _)).
    apply mon_rinvunitor_runitor.
  Qed.
End ImageEnriched.


Require Import HoTT.
From GR.bicategories Require Import
     bicategory.bicategory
     bicategory.examples.full_sub
     lax_functor.lax_functor
     lax_functor.examples.factor_full_sub
     lax_transformation.lax_transformation
     lax_transformation.examples.factor_full_sub
     modification.modification
     general_category.

Definition factor_modification
           {C D : BiCategory}
           {F G : LaxFunctor C D}
           {η₁ η₂ : LaxTransformation F G}
           (P : D -> hProp)
           (σ : Modification η₁ η₂)
           (FH : forall (X : C), P (F X))
           (GH : forall (X : C), P (G X))
  : Modification
      (lax_factor_transformation P η₁ FH GH)
      (lax_factor_transformation P η₂ FH GH)
  := Build_Modification
       (fun A => mod_component σ A)
       (fun A B f => mod_commute σ f).