(** The [delay] type and Capretta's partiality monad *)

(** The type [delay A] represents computations that produce a result
    of type [A] if they terminate, but can also diverge. *)

CoInductive delay (A: Type) :=
  | now : A -> delay A
  | later : delay A -> delay A.

Arguments now [A].
Arguments later [A].

Lemma u_delay:
  forall {A: Type} (x: delay A),
  x = match x with now v => now v | later y => later y end.
Proof. destruct x; auto. Qed.

Ltac unroll_delay X := rewrite (u_delay X); cbn.

(** The monad structure. *)

Definition ret := now.

CoFixpoint bind {A B: Type} (d: delay A) (f: A -> delay B) :=
  match d with
  | now v => later (f v)
  | later d' => later (bind d' f)
  end.

(** [safe Q d] means: if the computation [d] terminates,
    its value satisfies predicate [Q].  It's like a postcondition
    in a weak Hoare triple. *)

CoInductive safe {A: Type} (Q: A -> Prop) : delay A -> Prop :=
  | safe_now: forall a, Q a -> safe Q (now a)
  | safe_later: forall d, safe Q d -> safe Q (later d).

Lemma safe_inv_now: forall {A: Type} (Q: A -> Prop) v,
  safe Q (now v) -> Q v.
Proof.
  intros. inversion H. auto.
Qed.

Lemma safe_inv_later: forall {A: Type} (Q: A -> Prop) d,
  safe Q (later d) -> safe Q d.
Proof.
  intros. inversion H. auto.
Qed.

Lemma safe_consequence:
  forall {A: Type} (Q1 Q2: A -> Prop),
  (forall a, Q1 a -> Q2 a) ->
  forall (d: delay A), safe Q1 d -> safe Q2 d.
Proof.
  intros until Q2; intros IMP. cofix COINDHYP; destruct 1.
- constructor; auto.
- constructor; auto.
Qed.

Lemma safe_bind:
  forall {A B: Type} (Q1: A -> Prop) (Q2: B -> Prop)
         (d: delay A) (f: A -> delay B),
  safe Q1 d -> (forall v, Q1 v -> safe Q2 (f v)) -> safe Q2 (bind d f).
Proof.
  intros until Q2. cofix COINDHYP; intros.
  unroll_delay (bind d f). destruct d.
- apply safe_inv_now in H. constructor. apply H0. auto.
- apply safe_inv_later in H. constructor. apply COINDHYP; auto.
Qed.


From Hammer Require Import Hammer.

Global Set Automatic Coercions Import.
Set Implicit Arguments.

Require Import List.
From QuicksortComplexity Require Import list_utils.
From QuicksortComplexity Require Import util.

Record Monad: Type :=
{ mon:> Set -> Set
; bind: forall a b, mon a -> (a -> mon b) -> mon b
; ret: forall (a: Set), a -> mon a

; mon_lunit: forall (a b: Set) (x: a) (f: a -> mon b), bind (ret x) f = f x

; mon_runit: forall (a: Set) (f: mon a), bind f (@ret a) = f

; mon_assoc: forall a b c (n: mon a) (f: a -> mon b) (g: b -> mon c),
bind (bind n f) g =
bind n (fun x => bind (f x) g)

}.

Arguments bind [m a b].
Arguments ret {m a}.

Notation "x >>= y" := (bind x y) (at level 55).
Notation "x >> y" := (bind x (fun _ => y)) (at level 30, right associativity).
Notation "x <- y ; z" := (bind y (fun x : _ => z)) (at level 30, right associativity).

Record Functor: Type :=
{ func: Set -> Set
; func_map: forall (a b: Set) (f: a -> b), func a -> func b

; func_id: forall (X: Set), func_map (fun (x: X) => x) = (fun (x: func X) => x)

; func_assoc: forall (a b c: Set) (x: func a) (f: b -> c) (g: a -> b),
func_map (f ∘ g) x = func_map f (func_map g x)

}.

Arguments func_map [f a b].

Definition extMonad (M: Monad): Prop := forall (A B: Set) (f g: A -> M B), ext_eq f g -> forall x, bind x f = bind x g.

Lemma bind_eqq (M: Monad) (e: extMonad M) (A B: Set) (m n: M A) (f g: A -> M B):
m = n -> ext_eq f g -> (m >>= f) = (n >>= g).
Proof. hammer_hook "monads" "monads.bind_eqq". intros. subst. apply e. assumption. Qed.

Definition extFlipped (M: Monad): extMonad M -> forall A (x: M A) (B: Set) (f g: A -> M B), ext_eq f g -> bind x f = bind x g.
Proof. hammer_hook "monads" "monads.extFlipped". auto. Defined.

Lemma mon_lunit_under_bind (M: Monad) (A B C: Set) (a: M A) (b: A -> B) (f: A -> B -> M C):
extMonad M -> (x <- a ; (ret (b x) >>= f x)) = (x <- a ; f x (b x)).
Proof with auto. hammer_hook "monads" "monads.mon_lunit_under_bind".
intros.
apply H.
intro.
apply mon_lunit.
Qed.

Section MonadFunctor.

Variable M: Monad.

Definition bind_map (a b: Set) (f: a -> b) (x: M a): M b :=
xv <- x ;
ret (f xv).

Hypothesis f_ext_eq: forall A B (f g: A -> B), (forall x, f x = g x) -> f = g.

Lemma eta A B (f: A -> B): (fun x => f x) = f.
intros.
apply f_ext_eq.
auto.
Qed.

Definition MonadFunctor: Functor.
Proof with auto. hammer_hook "monads" "monads.MonadFunctor".
apply (Build_Functor M bind_map).
intros.
apply f_ext_eq.
intro.
unfold bind_map.
rewrite (eta (@ret M X)).
apply mon_runit.
intros.
unfold bind_map.
unfold compose.
rewrite mon_assoc.
replace (fun xv: a => ret (m:=M) (f (g xv))) with (fun x0: a =>
bind (m:=M) (b:=c) (ret (m:=M) (g x0))
(fun xv: b => ret (m:=M) (f xv)))...
apply f_ext_eq.
intros.
rewrite mon_lunit...
Defined.

Definition a_monad_isa_functor T (x: M T): func MonadFunctor T := x.

End MonadFunctor.

Module IdMonad.

Definition C (s: Set): Set := s.

Definition bind A B (x: C A) (y: A -> C B): C B := y x.
Definition ret (A: Set) (x: A): C A := x.

Definition M: Monad.
Proof. hammer_hook "monads" "monads.MonadFunctor.M". apply (Build_Monad C bind ret); auto. Defined.

Coercion id_isa_monad A (a: C A): M A := a.

Lemma ext: extMonad M.
Proof. hammer_hook "monads" "monads.IdMonad.ext". compute. auto. Qed.

End IdMonad.

Unset Elimination Schemes.

Inductive Tree (A: Set): Set :=
| Leaf: A -> Tree A
| Node: list (Tree A) -> Tree A.

Set Elimination Schemes.

Definition Tree_ind
: forall (A: Set) (P : Tree A -> Prop),
(forall n : A, P (Leaf n)) ->
(forall l : list (Tree A), (forall t, In t l -> P t) -> P (Node l)) ->
forall t, P t.
Proof with auto. hammer_hook "monads" "monads.Tree_ind".
intros A P Hbase Hrcd.
refine (fix IH (t:Tree A) {struct t} : P t := _).
case t; intros.
apply Hbase.
apply Hrcd.
induction l.
simpl.
intros.
contradiction.
simpl.
intros.
destruct H.
subst t0.
apply IH.
apply IHl.
assumption.
Qed.

Section MonadToys.

Definition liftM (A B: Set) (f: A -> B) (M: Monad) (x: M A): M B :=
xv <- x ; ret (f xv).

Definition liftM2 (A B C: Set) (f: A -> B -> C) (M: Monad) (x: M A) (y: M B): M C :=
xv <- x ; yv <- y ; ret (f xv yv).

Fixpoint foldlM {A B: Set} {M: Monad} (f: A -> B -> M A) (x: A) (l: list B) {struct l}: M A :=
match l with
| nil => ret x
| h :: t => fax <- f x h ; foldlM f fax t
end.

Fixpoint foldrM {A B: Set} {M: Monad} (f: B -> A -> M A) (x: A) (l: list B) {struct l}: M A :=
match l with
| nil => ret x
| h :: t => t' <- foldrM f x t; f h t'
end.

Lemma foldlM_cons (A B: Set) (M: Monad) (f: A -> B -> M A) (x: A) (h: B) (t: list B):
foldlM f x (h :: t) = fax <- f x h ; foldlM f fax t.
Proof. hammer_hook "monads" "monads.foldlM_cons". auto. Qed.

Fixpoint filterM {A: Set} {M: Monad} (p: A -> M bool) (l: list A): M (list A) :=
match l with
| nil => ret nil
| h :: t =>
b <- p h ;
t' <- filterM p t ;
ret (if b then h :: t' else t')
end.

Lemma filterM_id (A: Set) (p: A -> IdMonad.M bool) (l: list A): filter p l = filterM p l.
Proof with auto. hammer_hook "monads" "monads.filterM_id".
induction l...
simpl.
rewrite IHl...
Qed.

End MonadToys.

Arguments liftM [A B] _ [M].

Record MonadTrans: Type :=
{ transMonad: forall (m: Monad), extMonad m -> Monad
; lift: forall (m: Monad) (e: extMonad m) (A: Set), m A -> transMonad e A
}.


Add Rec LoadPath "/home/daniel/UniMath/UniMath" as UniMath.

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.precategories.
Require Import RezkCompletion.functors_transformations.

Load p2cMisc.

Local Notation "a ==> b" := (precategory_morphisms a b) (at level 50).
(* Local Notation "'hom' a b" := (precategory_morphisms a b) (at level 2). *)
Local Notation "f ;; g" := (compose f g) (at level 50, format "f  ;;  g").

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "D ^^ C" := (hs_funct_precat C D) (at level 2).
Local Notation "[ C , D ]'" := (funct_cat C D) (at level 2).

(** This is "already defined," I think in the Load?
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).
**)

(* nested sigma definition of a 2-precategory this closely mirrors the
   precategories.v file

   pre2cat_ob_mor
   - objects
   - morphisms

   pre2cat_1data
   - composition
   - identity

   pre2cat_2data
   - associativity
   - right unitor
   - left unitor

   pre2category
   - pentagon
   - unitor triangle

*)

(* objects and hom categories *)
Definition pre2cat_ob_mor
:= total2(fun C : UU => C -> C -> hs_precategory).

(* function for constructing an ob mor pair *)
Definition pre2cat_ob_mor_pair
  (C : UU) (mor : C -> C -> hs_precategory)
    : pre2cat_ob_mor
:= tpair _ C mor.

(* one of several coercier functions so that we can consider C as its
   type of objects as well as a category, so we can do things like a : C
   without resorting to something like a : ob C *)
Definition pre2cat_ob_mor_to_UU_coercer
  : pre2cat_ob_mor -> UU
:= fun C => @pr1 _ _ C.
Coercion pre2cat_ob_mor_to_UU_coercer : pre2cat_ob_mor >-> UU.

Definition homc
  {C : pre2cat_ob_mor}
    : C -> C -> hs_precategory
:= pr2 C.

Local Notation "a --> b" := (homc a b) (at level 50).

(*
Local Notation "'homc' C" := (pre2cat_hom (C := C)) (at level 2).
*)

Definition pre2cat_id
  (C : pre2cat_ob_mor)
:= forall a : C, (a --> a) ^^ terminal_cat.

Definition pre2cat_comp
  (C : pre2cat_ob_mor)
:= forall a b c : C, ((a --> c) ^^ (b --> c)) ^^ (a --> b).

Definition pre2cat_1data
:= total2 (fun C => dirprod (pre2cat_id C) (pre2cat_comp C)).

Definition pre2cat_1data_to_ob_mor_coercer
  (C : pre2cat_1data)
    : pre2cat_ob_mor
:= pr1 C.
Coercion pre2cat_1data_to_ob_mor_coercer
  : pre2cat_1data >-> pre2cat_ob_mor.

Definition pre2cat_1data_pair
  (C : pre2cat_ob_mor)
  (id : forall a : C, (a --> a) ^^ terminal_cat)
  (comp : forall a b c : C, ((a --> c) ^^ (b --> c)) ^^ (a --> b))
    : pre2cat_1data
:= tpair _ C (dirprodpair id comp).

(* lemmas for the id functor *)

Definition pre2cat_id_from_1data
  (C : pre2cat_1data)
    : pre2cat_id C
:= pr1 (pr2 C).

Definition id_funct
  {C : pre2cat_1data} {a : C}
    : functor terminal_cat (a --> a).
Proof.
  apply (pre2cat_id_from_1data C a).
Defined.

Definition id_funct_cat
  {C : pre2cat_1data} (a : C)
    : (a --> a) ^^ terminal_cat.
Proof.
  apply (pre2cat_id_from_1data C a).
Defined.

Definition id_functor
  {C : pre2cat_1data} (a : C)
    : functor terminal_cat (a --> a).
Proof.
  apply (pre2cat_id_from_1data C a).
Defined.

Definition id_mor
  {C : pre2cat_1data}
    : forall a : C, (a --> a).
Proof.
  intro a.
  apply (id_funct tt).
Defined.

(* lemmas for the comp functor *)

Definition pre2cat_comp_from_1data
  (C : pre2cat_1data)
    : pre2cat_comp C
:= pr2 (pr2 C).

Definition comp_funct
  {C : pre2cat_1data} {a b c : C}
    : functor (a --> b) ((a --> c) ^^ (b --> c)).
Proof.
  apply (pre2cat_comp_from_1data C a b c).
Defined.

Definition comp_functor
  {C : pre2cat_1data} (a b c : C)
    : functor (a --> b) ((a --> c) ^^ (b --> c)).
Proof.
  apply (pre2cat_comp_from_1data C a b c).
Defined.

Definition mcomp
  {C : pre2cat_1data} {a b c : C}
    : (a --> b) -> (b --> c) -> (a --> c).
Proof.
  intros f g.
  apply (get_funct (comp_funct f) g).
Defined.

Definition lwhisk
  {C : pre2cat_1data} {a b c : C} {g g' : b --> c}
  (f : a --> b) (v : g ==> g')
    : mcomp f g ==> mcomp f g'.
Proof.
  apply (# (get_funct (comp_funct f))).
  apply v.
Defined.

Definition rwhisk
  {C : pre2cat_1data} {a b c : C} {f f' : a --> b}
  (u : f ==> f') (g  : b --> c)
    : mcomp f g ==> mcomp f' g.
Proof.
  (* why does this take so long? *)
  apply (# comp_funct u).
Defined.

(*
Definition vcomp
  {C : pre2cat_1data} {a b : C} {f g h : a --> b}
    : f ==> g -> g ==> h -> f ==> h.
Proof.
  intros u v.
  apply (u ;; v).
Defined.
*)

(* pre2cat_2data *)

(* associativity *)

(* composition of 3 arrows functor, brackets on the left *)
Definition comp3_left
  {C : pre2cat_1data} (a b c d: C)
    : (((a --> d) ^^ (c --> d)) ^^ (b --> c)) ^^ (a --> b)
:= functor_composite _ _ _ (comp_functor a b c)
                           (funct_postcomp (b --> c) (comp_functor a c d)).

(* composition of 3 arrows functor, brackets on the right *)
Definition comp3_right
  {C : pre2cat_1data} (a b c d: C)
    : (((a --> d) ^^ (c --> d)) ^^ (b --> c)) ^^ (a --> b).
Proof.
  apply funct_arg_swap.
  apply (funct_postcomp _ funct_arg_swap).
  apply (functor_composite _ ((b --> d) ^^ (c --> d)) _).
  apply (comp_functor b c d).
  apply funct_postcomp.
  apply funct_arg_swap.
  apply (comp_functor a b d).
Defined.

(* these two are sanity checks, not sure if they are needed later *)
Definition comp3_is_mcomp_left
  {C : pre2cat_1data} {a b c d : C}
  (f : a --> b) (g : b --> c) (h : c --> d)
    : tget_funct (comp3_left a b c d) f g h
         = mcomp (mcomp f g) h.
Proof.
  simpl.
  apply idpath.
Defined.

Definition comp3_is_mcomp_right
  {C : pre2cat_1data} {a b c d : C}
  (f : a --> b) (g : b --> c) (h : c --> d)
    : tget_funct (comp3_right a b c d) f g h
         = mcomp f (mcomp g h).
Proof.
  simpl.
  apply idpath.
Defined.

Definition pre2cat_assoc
  (C : pre2cat_1data)
:= forall a b c d : C, iso (comp3_left a b c d) (comp3_right a b c d).

(*
Definition pre2cat_str_assoc
  (C : pre2cat_1data)
:= forall a b c d : C, comp3_left a b c d = comp3_right a b c d.

(* this will be used later to get a weak pre2cat from a strict one *)
Definition pre2cat_weaken_assoc
  (C : pre2cat_1data)
    : pre2cat_str_assoc C -> pre2cat_assoc C.
Proof.
  intro p.
  intros a b c d.
  apply idtoiso.
  apply p.
Defined.
*)

(* right and left unitors *)

(* compose with id functor on the right *)
Definition pre2cat_rcomp_unit
  {C : pre2cat_1data}  (a b : C)
    : ((a --> b) ^^ (a --> b)) ^^ terminal_cat.
Proof.
  apply (functor_composite _ (a --> a) _).
  apply (id_functor a).
  apply (comp_functor a a b).
Defined.

(* compose with id functor on the left *)
Definition pre2cat_lcomp_unit
  {C : pre2cat_1data}  (a b : C)
    : ((a --> b) ^^ (a --> b)) ^^ terminal_cat.
Proof.
  apply (functor_composite _ (b --> b) _).
  apply (id_functor b).
  apply funct_arg_swap.
  apply (comp_functor a b b).
Defined.

(* identity on (a --> b) *)
Definition pre2cat_id_on_homcat
  {C : pre2cat_1data}  (a b : C)
    : ((a --> b) ^^ (a --> b)) ^^ terminal_cat.
Proof.
  apply terminal_cat_functors.
  intro x.
  apply (functor_identity).
Defined.

(* identity on the right cancels *)
Definition pre2cat_runitor
  (C : pre2cat_1data)
:= forall a b : C, iso (pre2cat_rcomp_unit a b)
                       (pre2cat_id_on_homcat a b).

(* identity on the left cancels *)
Definition pre2cat_lunitor
  (C : pre2cat_1data)
:= forall a b : C, iso (pre2cat_lcomp_unit a b)
                       (pre2cat_id_on_homcat a b).

(*
Definition pre2cat_str_runitor
  (C : pre2cat_1data)
:= forall a b : C, (pre2cat_rcomp_unit a b) = (pre2cat_id_on_homcat a b).

Definition pre2cat_str_lunitor
  (C : pre2cat_1data)
:= forall a b : C, (pre2cat_lcomp_unit a b) = (pre2cat_id_on_homcat a b).

Definition pre2cat_weaken_runitor
  (C : pre2cat_1data)
    : pre2cat_str_runitor C -> pre2cat_runitor C.
Proof.
  intros p a b.
  apply idtoiso.
  apply p.
Defined.

Definition pre2cat_weaken_lunitor
  (C : pre2cat_1data)
    : pre2cat_str_lunitor C -> pre2cat_lunitor C.
Proof.
  intros p a b.
  apply idtoiso.
  apply p.
Defined.
*)

Definition pre2cat_2data
:= total2(fun C : pre2cat_1data => dirprod (pre2cat_assoc C)
                                     (dirprod (pre2cat_runitor C)
                                              (pre2cat_lunitor C))).

Definition pre2cat_2data_to_1data_coercer
  (C : pre2cat_2data)
    : pre2cat_1data
:= pr1 C.
Coercion pre2cat_2data_to_1data_coercer
  : pre2cat_2data >-> pre2cat_1data.

(*
Definition str_pre2cat_2data
:= total2( fun C : pre2cat_1data => dirprod (pre2cat_str_assoc C)
                                      (dirprod (pre2cat_str_runitor C)
                                               (pre2cat_str_lunitor C))).

(* sends assoc and unitor equalities to idtoiso fo them *)
Definition str_pre2cat_weaken_2data
  (C : str_pre2cat_2data)
    : pre2cat_2data.
Proof.
  apply (tpair _ (pr1 C)).
  split.
  apply (pre2cat_weaken_assoc (pr1 C)).
  apply (pr1 (pr2 C)).
  split.
  apply (pre2cat_weaken_runitor (pr1 C)).
  apply (pr1 (pr2 (pr2 C))).
  apply (pre2cat_weaken_lunitor (pr1 C)).
  apply (pr2 (pr2 (pr2 C))).
Defined.
Coercion str_pre2cat_weaken_2data
  : str_pre2cat_2data >-> pre2cat_2data.
*)

Definition comp_funct_assoc
  (C : pre2cat_2data)
:= pr1 (pr2 C).

(* associativity on morphisms *)
Definition massoc
  {C : pre2cat_2data} {a b c d : C}
    : forall (f : a --> b) (g : b --> c) (h : c --> d),
     iso (mcomp (mcomp f g) h) (mcomp f (mcomp g h)).
Proof.
  intros f g h.
  assert (M : iso
         (tget_funct (comp3_left a b c d) f g h)
         (tget_funct (comp3_right a b c d) f g h)).
  apply (functor_pointwise_iso_from_iso
          (functor_pointwise_iso_from_iso
            (functor_pointwise_iso_from_iso (comp_funct_assoc C a b c d) f)
           g)).
  rewrite comp3_is_mcomp_left in M.
  rewrite comp3_is_mcomp_right in M.
  apply M.
Defined.

(*
Definition str_massoc
  {C : str_pre2cat_2data} {a b c d : C}
    : forall (f : a --> b) (g : b --> c) (h : c --> d),
     (mcomp (mcomp f g) h) = (mcomp f (mcomp g h)).
Proof.
  intros f g h.
  set (p := (pr1 (pr2 C))).
  apply ((maponpaths (fun F => tget_funct F f g h)) (p a b c d)).
Defined.
*)

(* pentagon *)

(* This is the two-side path of the pentagon which is simpler since it only
   uses bare massoc *)
Definition pre2cat_pentagon1
  {C : pre2cat_2data} {a b c d e : C}
    : forall (f : a --> b) (g : b --> c) (h : c --> d) (k : d --> e),
        iso (mcomp (mcomp (mcomp f g) h) k) (mcomp f (mcomp g (mcomp h k))).
Proof.
  intros f g h k.
  (* (((fg)h)k) -~> ((fg)(hk)) *)
  apply (iso_comp_via (mcomp (mcomp f g) (mcomp h k))).
  apply (massoc (mcomp f g) h k).
  (* ((fg)(hk)) -~> (f(g(hk))) *)
  apply (massoc f g (mcomp h k)).
Defined.

(* this is the three-side path. There is implicitly some whiskering going on,
   but it would be more work to prove that whiskering of an iso is an iso.
   If one were to prove that, looking at this lemma would be a good place to
   start. *)
Definition pre2cat_pentagon2
  {C : pre2cat_2data} {a b c d e : C}
    : forall f : (a --> b),
      forall g : (b --> c),
      forall h : (c --> d),
      forall k : (d --> e),
        iso (mcomp (mcomp (mcomp f g) h) k) (mcomp f (mcomp g (mcomp h k))).
Proof.
  intros f g h k.
  (* (((fg)h)k) -~> ((f(gh))k) *)
  apply (iso_comp_via (mcomp (mcomp f (mcomp g h)) k)).
  - (* we prove this by proving that the comp functor applied to the iso massoc
       is an iso *)
    assert (H : @iso ((a --> e) ^^ (d --> e)) (comp_funct (mcomp (mcomp f g) h))
                                            (comp_funct (mcomp f (mcomp g h)))).
    + apply (functor_on_iso _ _ _ _ _ (massoc f g h)).
    + apply (functor_pointwise_iso_from_iso H).
  - (* ((f(gh))k) -~> (f((gh)k)) *)
    apply (iso_comp_via (mcomp f (mcomp (mcomp g h) k))).
    + apply (massoc f (mcomp g h) k).
    + (* (f((gh)k)) -~> (f(g(hk))) *)
      apply (functor_on_iso _ _ _ _ _ (massoc g h k)).
Defined.

Definition pre2cat_pentagon
  (C : pre2cat_2data)
:= forall (a b c d e : C)
          (f : a --> b) (g : b --> c) (h : c --> d) (k : d --> e),
     pre2cat_pentagon1 f g h k = pre2cat_pentagon2 f g h k.

(* unitor triangle *)

(* this is a rather different style of proof. Are there drawbacks to it? *)
Definition mrunit
  {C : pre2cat_2data} {a b: C}
  (f : a --> b)
    : iso (mcomp (id_mor a) f) f.
Proof.
  set (runit := (pr1 (pr2 (pr2 C)))).
  set (runitab := runit a b).
  set (H := (functor_pointwise_iso_from_iso runitab) tt).
  set (J := (functor_pointwise_iso_from_iso H) f).
  apply J.
Defined.

Definition mlunit
  {C : pre2cat_2data} {a b: C}
  (f : a --> b)
    : iso (mcomp f (id_mor b)) f.
Proof.
  set (lunitab := (pr2 (pr2 (pr2 C))) a b).
  set (H := (functor_pointwise_iso_from_iso
              ((functor_pointwise_iso_from_iso lunitab) tt) f)).
  apply H.
Defined.

Definition pre2cat_unitriangle1
  (C : pre2cat_2data) {a b c: C}
  (f : a --> b) (g : b --> c)
    : iso (mcomp (mcomp f (id_mor b)) g) (mcomp f g).
Proof.
  assert (H : @iso ((a --> c) ^^ (b --> c)) (comp_funct (mcomp f (id_mor b)))
                                            (comp_funct f )).
  apply (functor_on_iso _ _ _ _ _ (mlunit f)).
  apply (functor_pointwise_iso_from_iso H).
Defined.

Definition pre2cat_unitriangle2
  (C : pre2cat_2data) {a b c: C}
  (f : a --> b) (g : b --> c)
    : iso (mcomp (mcomp f (id_mor b)) g) (mcomp f g).
Proof.
  apply (iso_comp_via (mcomp f (mcomp (id_mor b) g))).
  - apply massoc.
  - apply (functor_on_iso _ _ _ _ _ (mrunit g)).
Defined.

Definition pre2cat_unitriangle
  (C : pre2cat_2data)
:= forall (a b c: C) (f : a --> b) (g : b --> c),
     pre2cat_unitriangle1 C f g = pre2cat_unitriangle2 C f g.

(* main definitions *)

Definition pre2cats
:= total2(fun C : pre2cat_2data => dirprod (pre2cat_pentagon C)
                                           (pre2cat_unitriangle C)).

(*
Definition str_pre2cats
:= total2(fun C : str_pre2cat_2data => dirprod (pre2cat_pentagon C)
                                           (pre2cat_unitriangle C)).
*)

Definition pre2cats_to_pre2cat_2data_coercer
  : pre2cats -> pre2cat_2data
:= pr1.
Coercion pre2cats_to_pre2cat_2data_coercer
  : pre2cats >-> pre2cat_2data.

(*
Definition str_pre2cats_weaken
  : str_pre2cats -> pre2cats.
Proof.
  intro C.
  (* why doesn't the coercion work? *)
  apply (tpair _ (str_pre2cat_weaken_2data (pr1 C))).
  split.
  apply (pr1 (pr2 C)).
  apply (pr2 (pr2 C)).
Defined.
Coercion str_pre2cats_weaken
  : str_pre2cats >-> pre2cats.
*)

(* construction lemmas *)

(* assoc *)

(* the following four definitions are to make the later lemmas shorter *)
Definition pre2cat_massoc_type
  {C : pre2cat_1data} (a b c d : C)
:= forall f : a --> b,
   forall g : b --> c,
   forall h : c --> d,
     iso (mcomp (mcomp f g) h) (mcomp f (mcomp g h)).

Definition pre2cat_llwhisk_assoc_type
  {C : pre2cat_1data} {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
:= forall (f : a --> b) (g : b --> c)
          (h h' : c --> d) (w : h ==> h'),
            lwhisk (mcomp f g) w ;; asc f g h'
              = asc f g h ;; lwhisk f (lwhisk g w).

Definition pre2cat_lrwhisk_assoc_type
  {C : pre2cat_1data} {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
:= forall (f : a --> b)
          (g g' : b --> c) (v : g ==> g')
          (h : c --> d),
            rwhisk (lwhisk f v) h ;; asc f g' h
              = asc f g h ;; lwhisk f (rwhisk v h).

Definition pre2cat_rrwhisk_assoc_type
  {C : pre2cat_1data} {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
:= forall (f f': a --> b) (u : f ==> f')
          (g : b --> c) (h : c --> d),
            rwhisk (rwhisk u g) h ;; asc f' g h
              = asc f g h ;; rwhisk u (mcomp g h).

(* we construct the assoc constructor iteratively, removing arguments *)
Definition pre2cat_assoc_constructor1
  {C : pre2cat_1data}
  {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
  (ll : pre2cat_llwhisk_assoc_type asc)
    : forall f : a --> b,
      forall g : b --> c,
         (dget_funct (comp3_left a b c d) f g)
           ==> (dget_funct (comp3_right a b c d) f g).
Proof.
  intros f g.
  apply mor_to_nat_trans.
  unfold dget_funct; unfold get_funct.
  set (H := (asc f g)).
  apply (tpair _ (fun h : c --> d => (pr1 (asc f g h)) )).
  intros h h' w.
  apply ll.
Defined.

(*
Definition pre2cat_assoc_constructor1'
  {C : pre2cat_1data}
  {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
  (ll : pre2cat_llwhisk_assoc_type asc)
    : forall f : a --> b,
      forall g : b --> c,
         iso (dget_funct (comp3_left a b c d) f g)
             (dget_funct (comp3_right a b c d) f g).
Proof.
  intros f g.
  set (H := (pre2cat_assoc_constructor1 asc ll f g)).
  apply (functor_iso_from_pointwise_iso _ _ _ _ _ H).
  intro h.
  apply (pr2 (asc f g h)).
Defined.
*)

Definition pre2cat_assoc_constructor2
  {C : pre2cat_1data}
  {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
  (ll : pre2cat_llwhisk_assoc_type asc)
  (lr : pre2cat_lrwhisk_assoc_type asc)
    : forall f : a --> b,
        get_funct (comp3_left a b c d) f
           ==> get_funct (comp3_right a b c d) f.
Proof.
  intro f; unfold get_funct.
  apply mor_to_nat_trans.
  apply (tpair _ (pre2cat_assoc_constructor1 asc ll f)).
  intros g g' v; simpl.
  apply nat_trans_eq.
  apply get_hs.
  intro h.
  simpl.
  apply lr.
  (* why does this take so long? *)
Defined.

(*
Definition pre2cat_assoc_constructor2'
  {C : pre2cat_1data}
  {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
  (ll : pre2cat_llwhisk_assoc_type asc)
  (lr : pre2cat_lrwhisk_assoc_type asc)
    : forall f : a --> b,
        iso (get_funct (comp3_left a b c d) f)
            (get_funct (comp3_right a b c d) f).
Proof.
  intro f; unfold get_funct.
  set (H := (pre2cat_assoc_constructor2 asc ll lr f));
  unfold get_funct in H.
  apply (functor_iso_from_pointwise_iso _ _ _ _ _ H).
  intro g.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _ ).
  intro h.
  apply (pr2 (asc f g h)).
Defined.
*)

Definition pre2cat_assoc_constructor3
  {C : pre2cat_1data} {a b c d : C}
  (asc : pre2cat_massoc_type a b c d)
  (ll : pre2cat_llwhisk_assoc_type asc)
  (lr : pre2cat_lrwhisk_assoc_type asc)
  (rr : pre2cat_rrwhisk_assoc_type asc)
   : comp3_left a b c d ==> comp3_right a b c d.
Proof.
  apply mor_to_nat_trans.
  unfold get_funct.
  apply (tpair _ (pre2cat_assoc_constructor2 asc ll lr)).
  intros f f' u.
  apply nat_trans_eq.
  apply get_hs.
  intro g.
  apply nat_trans_eq.
  apply get_hs.
  intro h.
  apply rr. (* slow *)
Defined.

Definition pre2cat_assoc_constructor
  {C : pre2cat_1data} (a b c d : C)
  (asc : pre2cat_massoc_type a b c d)
  (ll : pre2cat_llwhisk_assoc_type asc)
  (lr : pre2cat_lrwhisk_assoc_type asc)
  (rr : pre2cat_rrwhisk_assoc_type asc)
   : iso (comp3_left a b c d) (comp3_right a b c d).
Proof.
  set (H := (pre2cat_assoc_constructor3 asc ll lr rr)).
  apply (functor_iso_from_pointwise_iso _ _ _ _ _ H).
  intro f.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _ ).
  intro g.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _ ).
  intro h.
  apply (pr2 (asc f g h)).
Defined.

Definition pre2cat_assoc_constructor'
  {C : pre2cat_1data}
  (asc : forall a b c d : C, pre2cat_massoc_type a b c d)
  (ll : forall a b c d : C, pre2cat_llwhisk_assoc_type (asc a b c d))
  (lr : forall a b c d : C, pre2cat_lrwhisk_assoc_type (asc a b c d))
  (rr : forall a b c d : C, pre2cat_rrwhisk_assoc_type (asc a b c d))
   : forall a b c d : C, iso (comp3_left a b c d) (comp3_right a b c d).
Proof.
  intros a b c d.
  set (H := (pre2cat_assoc_constructor3 (asc a b c d)
                                        (ll a b c d)
                                        (lr a b c d)
                                        (rr a b c d))).
  apply (functor_iso_from_pointwise_iso _ _ _ _ _ H).
  intro f.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _ ).
  intro g.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _ ).
  intro h.
  apply (pr2 (asc a b c d f g h)).
Defined.

(* unitor constructors *)

Definition pre2cat_mrunitor_type
  (C : pre2cat_1data)
:= forall (a b : C) (f : a --> b), iso (mcomp (id_mor a) f) f.

Definition pre2cat_lwhisk_unit_type
  {C : pre2cat_1data}
  (runit : pre2cat_mrunitor_type C)
:= forall (a b : C) (f f': a --> b) (u : f ==> f'),
      lwhisk (id_mor a) u ;; runit a b f' = runit a b f ;; u.

Definition pre2cat_runitor_constructor1
  {C : pre2cat_1data}
  (runit : pre2cat_mrunitor_type C)
  (lwsku : pre2cat_lwhisk_unit_type runit)
    : forall (a b : C) (x : terminal_cat),
           get_funct (pre2cat_rcomp_unit a b) x
             ==> get_funct (pre2cat_id_on_homcat a b) x.
Proof.
  intros a b.
  intro x; destruct x.
  apply mor_to_nat_trans; unfold get_funct.
  apply (tpair _ (fun f => pr1 (runit a b f))).
  intros g h u.
  simpl.
  apply (lwsku a b g h u).
Defined.

Definition terminal_cat_mor_is_id
  {a : terminal_cat} (f : a ==> a)
    :  f = identity a.
Proof.
  destruct f.
  destruct (identity a).
  apply idpath.
Defined.

Definition pre2cat_runitor_constructor2
  {C : pre2cat_1data}
  (runit : pre2cat_mrunitor_type C)
  (lwsku : pre2cat_lwhisk_unit_type runit)
    : forall a b : C, (pre2cat_rcomp_unit a b) ==> (pre2cat_id_on_homcat a b).
Proof.
  intros a b.
  apply mor_to_nat_trans; unfold get_funct.
  apply (tpair _ ((pre2cat_runitor_constructor1 runit lwsku) a b)).
  intros x y u.
  apply nat_trans_eq.
  apply get_hs.
  intro f.
  destruct x, y.
  simpl.
  rewrite (terminal_cat_mor_is_id u).

  pathvia (identity (mcomp (id_mor a) f) ;; (pr1 (runit a b f))).
  - apply (maponpaths (fun u => u ;; (pr1 (runit a b f)))).
    (* for some reason this doesn't work if I add in the tt argument to T
       *)
    set (T := functor_id (id_functor a) ).
    rewrite T.
    assert (U : #(comp_functor a a b) (identity ((id_functor a) tt))
                  = identity ((comp_functor a a b) ((id_functor a) tt))).
    apply functor_id.
    pathvia (identity
              (get_funct ((comp_functor a a b) ((id_functor a) tt)) f)
            ).
    + apply (maponpaths (get_nat)) in U.
      apply (maponpaths
               (fun F : nat_trans
         (get_funct ((comp_functor a a b) ((id_functor a) tt)))
         (get_funct ((comp_functor a a b) ((id_functor a) tt)))
                                => F f)) in U.
      apply U.
    + apply idpath.
  - pathvia (pr1 (runit a b f)).
    apply id_left.
    apply pathsinv0.
    apply id_right.
Defined.

Definition pre2cat_assoc_constructor_exp
  {C : pre2cat_1data} (a b c d : C)
  (asc : pre2cat_massoc_type a b c d)
  (ll : pre2cat_llwhisk_assoc_type asc)
  (lr : pre2cat_lrwhisk_assoc_type asc)
  (rr : pre2cat_rrwhisk_assoc_type asc)
   : iso (comp3_left a b c d) (comp3_right a b c d).
Proof.
  set (H := (pre2cat_assoc_constructor3 asc ll lr rr)).
  Check functor_iso_from_pointwise_iso.
  apply (functor_iso_from_pointwise_iso _ _ _ _ _ H).
  intro f.
  Check functor_iso_if_pointwise_iso.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _ ).
  intro g.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _ ).
  intro h.
  apply (pr2 (asc f g h)).
Defined.

Definition pre2cat_runitor_constructor
  {C : pre2cat_1data}
  (runit : forall (a b : C) (f : a --> b), iso (mcomp (id_mor a) f) f)
  (lwsku : pre2cat_lwhisk_unit_type runit)
    : pre2cat_runitor C.
Proof.
  intros a b.
  apply (functor_iso_from_pointwise_iso _ _ _ _ _
           ((pre2cat_runitor_constructor2 runit lwsku) a b)).
  intro x.
  apply (functor_iso_if_pointwise_iso _ _ _ _ _).
  intro f.
  set (H := pr2 (runit a b f)).
  Check (H f).
  apply (H f).

  simpl in H.
  unfold pre2cat_runitor_constructor2.
  apply H.

  apply (tpair _ ((pre2cat_runitor_constructor2 runit lwsku) a b)).

  Check functor_pointwise_iso_from_iso.

  set (H := (functor_pointwise_iso_from_iso runit a b) tt).
  set (J := (functor_pointwise_iso_from_iso H) f).
  apply (runit a b).

*)

(*
Definition pre2cat_assoc_strictness1
  (C : pre2cat_2data)
:= forall a b c d : C, comp3_left a b c d = comp3_right a b c d.

Definition pre2cat_assoc_strictness2
  {C : pre2cat_2data}
  (p : pre2cat_assoc_strictness1 C)
:= forall a b c d : C, idtoiso (p a b c d) = compFunctAssoc C a b c d.

Definition pre2cat_assoc_strictness
  (C : pre2cat_2data)
:= total2(@pre2cat_assoc_strictness2 C).

Definition pre2cat_strict_massoc1
  {C : pre2cat_2data} {a b c d: C}
  (p : pre2cat_assoc_strictness C)
  (f : a --> b) (g : b --> c) (h : c --> d)
    : mcomp (mcomp f g) h = mcomp f (mcomp g h).
Proof.
  destruct p as [p q].
  apply ((maponpaths (fun F => tget_funct F f g h)) (p a b c d)).
Defined.

Definition pre2cat_strict_massoc2
  {C : pre2cat_2data} {a b c d: C}
  (p : pre2cat_assoc_strictness C)
  (f : a --> b) (g : b --> c) (h : c --> d)
    : mcomp (mcomp f g) h = mcomp f (mcomp g h).
Proof.
  destruct p as [p q].
  unfold pre2cat_assoc_strictness1 in p.
  unfold pre2cat_assoc_strictness2 in q.
  set (r := p a b c d).
  assert (s : p a b c d = r).
    apply idpath.
  rewrite s in q.
  destruct (p a b c d).
  apply ((maponpaths (fun F => tget_funct F f g h)) (p a b c d)).
Defined.
*)

(* Theorem pre2cat_assoc_strict_to_weak
     {C : pre2cat_2data} {a b c d e: C}
     {f : a --> b} {g : b --> c} {h : c --> d} {k : d --> e}
     (p : pre2cat_assoc_strictness C)
       : pre2cat_pentagon f g h k.
   Proof.
     unfold pre2cat_pentagon; unfold pre2cat_pentagon1; unfold pre2cat_pentagon2.
     unfold iso_comp_via. rewrite (pre2cat_strict_massoc p f g h).
     destruct (pre2cat_strict_massoc p f g h).
*)

(*
Definition str_pre2cat_pentagon1
  {C : str_pre2cat} {a b c d e : C}
    : forall (f : a --> b) (g : b --> c) (h : c --> d) (k : d --> e),
        (mcomp (mcomp (mcomp f g) h) k) = (mcomp f (mcomp g (mcomp h k))).
Proof.
  intros f g h k.
  pathvia (mcomp (mcomp f g) (mcomp h k)).
  apply (str_massoc (mcomp f g) h k).
  apply (str_massoc f g (mcomp h k)).
Defined.

Definition str_pre2cat_pentagon2
  {C : str_pre2cat} {a b c d e : C}
    : forall (f : a --> b) (g : b --> c) (h : c --> d) (k : d --> e),
        (mcomp (mcomp (mcomp f g) h) k) = (mcomp f (mcomp g (mcomp h k))).
Proof.
  intros f g h k.
  pathvia (mcomp (mcomp f (mcomp g h)) k).
  apply (maponpaths (fun x => mcomp x k)  (str_massoc f g h)).
  pathvia (mcomp f (mcomp (mcomp g h) k)).
  apply (str_massoc f (mcomp g h) k).
  apply (maponpaths _ (str_massoc g h k)).
Defined.
*)

(* this all goes earlier *)
(*
Lemma get_funct_idtoiso_commute
  (C : precategory) (D : hs_precategory)
  (F : D ^^ C)
  (a b : C)
  (p : a = b)
    : #(get_funct F) (pr1 (idtoiso p)) = idtoiso (maponpaths (get_funct F) p).
Proof.
  destruct p.
  apply functor_id.
Defined.
*)

(*
Lemma get_funct_idtoiso_commute
  {C : precategory} {D : hs_precategory}
  {F G : D ^^ C}
  (p : F = G)
  (a : C)
    : get_nat (pr1 (idtoiso p)) a
        = idtoiso (maponpaths (fun F => get_funct F a) p).
Proof.
  destruct p.
  apply idpath.
Defined.

Lemma tget_funct_idtoiso_commute
  {B C D : precategory} {E : hs_precategory}
  {F G : ((E ^^ D) ^^ C) ^^ B}
  (p : F = G)
  (b : B) (c : C) (d : D)
    : (get_nat (pr1 (get_nat (pr1 (idtoiso p)) b) c) d)
        = pr1 (idtoiso (maponpaths (fun F => tget_funct F b c d) p)).
Proof.
  destruct p.
  simpl.
  apply idpath.
Defined.

Lemma functor_on_iso_idtoiso_commute
  {C : precategory} {D : hs_precategory}
  {a b : C}
  (F : D ^^ C)
  (p : a = b)
    : functor_on_iso _ _ (get_funct F) _ _ (idtoiso p)
        = idtoiso (maponpaths (get_funct F) p).
Proof.
  destruct p.
  apply eq_iso.
  simpl.
  apply functor_id.
Defined.

Lemma str_pre2cat_massoc_is_idtoiso
  {C : str_pre2cat} {a b c d : C}
  (f : a --> b) (g : b --> c) (h : c --> d)
    : massoc f g h = idtoiso (str_massoc f g h).
Proof.
  apply eq_iso.
  unfold str_massoc.
  apply (tget_funct_idtoiso_commute (pr1 (pr2 C) a b c d) f g h).
Defined.

Lemma idtoiso_concat2
  {C : precategory} {a b c : C} (p : a = b) (q : b = c)
    : iso_comp (idtoiso p) (idtoiso q) = idtoiso (p @ q).
Proof.
  destruct p.
  simpl.
  apply eq_iso.
  unfold iso_comp.
  simpl.
  apply id_left.
Defined.

Theorem str_pre2cat_pentagon
  (C : str_pre2cat) {a b c d e : C}
  (f : a --> b) (g : b --> c) (h : c --> d) (k : d --> e)
    : pre2cat_pentagon (str_pre2cat_weaken_to_2data C) f g h k.
Proof.
  unfold pre2cat_pentagon; unfold pre2cat_pentagon1; unfold pre2cat_pentagon2.
  unfold iso_comp_via.
  rewrite (str_pre2cat_massoc_is_idtoiso (mcomp f g) h k).
  rewrite (str_pre2cat_massoc_is_idtoiso f g (mcomp h k)).
  pathvia (idtoiso ((str_massoc (mcomp f g) h k)
                     @ (str_massoc f g (mcomp h k)))).
  apply (idtoiso_concat2 _ _).
  rewrite (str_pre2cat_massoc_is_idtoiso g h k).
  rewrite (str_pre2cat_massoc_is_idtoiso f g h).
  rewrite (str_pre2cat_massoc_is_idtoiso f (mcomp g h) k).
  rewrite (functor_on_iso_idtoiso_commute).
  rewrite (idtoiso_concat2).
  pathvia (iso_comp
            (functor_pointwise_iso_from_iso
               (idtoiso (maponpaths _ (str_massoc f g h))) k)
            (idtoiso
               (str_massoc f (mcomp g h) k @
                maponpaths (get_funct (compFunct f)) (str_massoc g h k)))).
  -

*)

(*
Definition pre2cat_assoc_strictness1
 (C : pre2cat_1data)
:= @comp3left C = @comp3right C.

Definition pre2cat_assoc_strictness2
  {C : pre2cat_1data}
  (p : pre2cat_assoc_strictness1 C)
:= u = fun a b c d : C => nat_trans_id (comp3left a b c d).
*)


From stdpp Require Import list vector.

Class Functor (F : Type -> Type) := {
  fmap {A B : Type} (f : A -> B) (fa : F A) : F B;
  (*
  fmap_id {A : Type} : forall x, fmap (@id A) x = id x;
  fmap_compose {A B C : Type} : forall (g : B -> C) (h : A -> B) x, fmap (compose g h) x = compose (fmap g) (fmap h) x;
   *)
                                   }.

Delimit Scope functor_scope with functor.

(* Notation "f <$> a" := (@fmap _ _ _ _ f a) (at level 61, left associativity) : functor_scope. *)

Class Applicative (F : Type -> Type) `{Functor F} := {
  unit {A : Type} (a : A) : F A;
  ap {A B : Type} (f : F (A -> B)) (a : F A) : F B;
  (*
  ap_unit_id {A : Type} : forall (v : F A),
      ap (unit id) v = v;
  unit_composition {A B C : Type} : forall (u : F (B -> C)) (v : F (A -> B)) (w : F A),
      ap (ap (ap (unit compose) u) v) w = ap u (ap v w);
  unit_homomorphism {A B : Type} : forall (f : A -> B) (x : A),
      ap (unit f) (unit x) = unit (f x);
  unit_interchange {A B : Type} : forall (u : F (A -> B)) (y : A),
      ap u (unit y) = ap (unit (fun f => f y)) u;
   *)
                                                    }.

Delimit Scope applicative_scope with applicative.

Notation "f <*> a" := (@ap _ _ _ _ _ f a) (at level 62, left associativity) : applicative_scope.

Class Monad (M : Type -> Type) `{Applicative M} := {
  bind {A B : Type} : M A -> (A -> M B) -> M B;
  (*
  unit_l_id_bind {A B : Type} : forall (f : A -> M B) (a : A),
      bind (unit a) f = f a;
  unit_r_id_bind {A B : Type} : forall (ma : M A),
      bind ma unit = ma;
  bind_assoc {A B C : Type} : forall (f : A -> M B) (g : B -> M C) (ma : M A),
      bind ma (fun x => bind (f x) g) = bind (bind ma f) g;
   *)
                                                  }.

Definition join {M : Type -> Type} {A : Type} `{Monad M} (mma : M (M A)) : M A :=
  bind mma id.

Class Monoid (M : Type) := {
  op : M -> M -> M;
  neutral : M;
  unit_id_l : forall (a : M), op neutral a = a;
  unit_id_r : forall (a : M), op a neutral = a;
  op_assoc {a b c : M} : op a (op b c) = op (op a b) c;
                          }.

Class Foldable (T : Type -> Type) := {
  foldr {A B : Type} : (B -> A -> A) -> A -> T B -> A;
  fold_map {A : Type} {M : Type} `{Monoid M} : (A -> M) -> T A -> M;
                                   }.

Class Traversable (T : Type -> Type) `{Foldable T} `{Functor T} := {
  traverse {A B : Type} {F : Type -> Type} `{Applicative F} : (A -> F B) -> T A -> F (T B);
  sequence_a {A : Type} {F : Type -> Type} `{Applicative F} : T (F A) -> F (T A);
  }.

Module Option.

  Instance functor_option : Functor option.
  Proof.
    refine {| monad.fmap := fun {A B : Type} (f : A -> B) (x : option A) => match x with | None => None | Some x' => Some (f x') end; |}.
    (*
    - intros A [x |]; reflexivity.
    - intros A B C g h [x |]; reflexivity.
     *)
  Defined.

  Instance applicative_option : Applicative option.
  Proof.
    refine {| unit := fun {A : Type} (x : A) => Some x;
              ap := fun {A B : Type} (f : option (A -> B)) (a : option A) =>
                      match f with
                      | None => None
                      | Some f' =>
                        match a with
                        | None => None
                        | Some a' => Some (f' a')
                        end
                      end; |}.
    (*
    - intros A [v |]; reflexivity.
    - intros A B C [u |] [v |] [w |]; reflexivity.
    - reflexivity.
    - intros A B [u |] y; reflexivity.
     *)
  Defined.

  Instance monad_option : Monad option.
  Proof.
    refine {| bind t u mt f := match mt with | None => None | Some t => f t end;
           |}.
    (*
    - reflexivity.
    - intros ? ? [ma |]; reflexivity.
    - intros A B C f g [ma |]; reflexivity.
     *)
  Defined.

  Fixpoint list_from_some {A : Type} (l : list (option A)) : list A :=
    match l with
    | nil => nil
    | cons x xs =>
      match x with
      | None => list_from_some xs
      | Some x' => cons x' (list_from_some xs)
      end
    end.

  Definition bool_check_option {A : Type} (b : bool) : option bool :=
    match b with
    | false => None
    | true => Some true
    end.

End Option.

Module Sum.

  Instance functor_sum {E : Type} : Functor (sum E).
  Proof.
    refine {| fmap := fun {A B : Type} (f : A -> B) (x : E + A) => match x with
                                     | inl l => inl l
                                     | inr r => inr (f r)
                                 end
           |}.
    (*
    - intros A [e | a]; reflexivity.
    - intros A B C g h [e | a]; reflexivity.
     *)
  Defined.

  Instance applicative_sum {E : Type} : Applicative (sum E).
  Proof.
    refine {| unit := fun {A : Type} (x : A) => inr x;
              ap := fun {A B : Type} (f : E + (A -> B)) (x : E + A) =>
                      match f with
                      | inl l => inl l
                      | inr r =>
                        match x with
                        | inl l' => inl l'
                        | inr r' => inr (r r')
                        end
                      end
           |}.
    (*
    - intros A [e | a]; reflexivity.
    - intros A B C [e1 | u] [e2 | v] [e3 | w]; reflexivity.
    - reflexivity.
    - intros ? ? [e | f] y; reflexivity.
     *)
  Defined.

  Instance monad_sum {E : Type} : Monad (sum E).
  Proof.
    refine {| bind t u mt f := match mt with | inl l => inl l | inr r => f r end;
           |}.
    (*
    - reflexivity.
    - intros ? ? [? | ?]; reflexivity.
    - intros ? ? ? f g [? | a]; [| destruct (f a)]; reflexivity.
     *)
  Defined.

End Sum.

Module List.

  Local Fixpoint list_bind {A B : Type} (l : list A) (f : A -> list B) : list B :=
    match l with
    | nil => nil
    | cons x xs => app (f x) (list_bind xs f)
    end.

  Instance functor_list : Functor list.
  Proof.
    refine {| fmap := map |}.
    (*
    - exact map_id.
    - symmetry.
      apply map_map.
     *)
  Defined.

  (* Local Fixpoint foldr_list {A B : Type} (f : A -> B -> B) (b : B) (l : list A) : B := *)
  (*   match l with *)
  (*   | nil => b *)
  (*   | cons x xs => f x (foldr_list f b xs) *)
  (*   end. *)

  Local Fixpoint fold_map_list {A M : Type} `{Monoid M} (f : A -> M) (l : list A) : M :=
    match l with
    | nil => neutral
    | cons x xs => op (f x) (fold_map_list f xs)
    end.

  Instance foldable_list : Foldable list.
  Proof.
    refine {| foldr := @stdpp.list.foldr ;
              fold_map := @fold_map_list ;|}.
  Defined.

  Local Definition sequence_a_list {A : Type} {F : Type -> Type} `{Applicative F} (l : list (F A)) : F (list A) :=
    foldr (fun val acc => ap (fmap cons val) acc) (unit nil) l.

  Local Definition traverse_list {A B : Type} {F : Type -> Type} `{Applicative F} (f : A -> F B) : list A -> F (list B) :=
    compose sequence_a_list (fmap f).

  Instance traversable_list : Traversable list.
  Proof.
    refine {| traverse := @traverse_list;
              sequence_a := @sequence_a_list;
           |}.
  Defined.

  Local Fixpoint ap_list {A B : Type} (f : list (A -> B)) (x : list A) : list B :=
    match (f, x) with
    | (nil, _) => nil
    | (_,  nil) => nil
    | (cons f' fs, ls) => app (fmap f' ls) (ap_list fs ls)
    end.

End List.

Module ListNoDup.
  From stdpp Require Import listset_nodup.

  Local Definition foldr_listset_nodup {A B : Type} (f : B -> A -> A) (b : A) (l : listset_nodup B) : A :=
    match l with
    | ListsetNoDup l' _ => foldr f b l'
    end.

  Local Definition fold_map_listset_nodup {A M : Type} `{Monoid M} (f : A -> M) (l : listset_nodup A) : M :=
    match l with
    | ListsetNoDup l' _ => fold_map f l'
    end.

  Instance foldable_listset_nodup : Foldable listset_nodup.
  Proof.
    refine {| fold_map := @fold_map_listset_nodup |}.
    apply @foldr_listset_nodup.
  Defined.

  (* Seems terribly wrong *)
  Lemma sequence_m_no_dup {A : Type} {M : Type -> Type} `{Monad M} (l : listset_nodup (M A)) : M (listset_nodup A).
  Proof.
    destruct l as [car prf].
    induction car as [| x xs HQ].
    - apply unit; apply empty.
    - eapply bind.
      + exact x.
      + intros a.
        eapply bind.
        * apply HQ.
          rewrite NoDup_ListNoDup in prf.
          rewrite List.NoDup_cons_iff in prf.
          destruct prf as [prf1 prf2].
          rewrite <- NoDup_ListNoDup in prf2.
          exact prf2.
        * intros l'.
          apply unit.
          exact l'.
    Defined.

End ListNoDup.

Module Vector.

  Local Fixpoint foldr_vec {A B : Type} {n : nat} (f : B -> A -> A) (b : A) (l : vec B n) : A :=
    match l with
    | vnil => b
    | vcons x xs => f x (foldr_vec f b xs)
    end.

  Local Fixpoint fold_map_vec {A M : Type} {n : nat} `{Monoid M} (f : A -> M) (l : vec A n) : M :=
    match l with
    | vnil => neutral
    | vcons x xs => op (f x) (fold_map_vec f xs)
    end.

  Instance foldable_vec {n : nat} : Foldable (fun x => vec x n).
  Proof.
    refine {| foldr := fun A B f acc v => @foldr_vec A B _ f acc v;
              fold_map := fun A M _ f v => @fold_map_vec A M _ _ f v ;|}.
  Defined.

  Local Fixpoint sequence_a_vec {A : Type} {F : Type -> Type} {n : nat} `{Applicative F} (l : vec (F A) n) : F (vec A n) :=
    match l with
    | vnil => unit vnil
    | @Vector.cons _ x n xs => ap (fmap (fun y => @vcons A y n) x) (sequence_a_vec xs)
    end.

  Local Definition traverse_vec {A B : Type} {F : Type -> Type} {n : nat} `{Applicative F} (f : A -> F B) : vec A n -> F (vec B n) :=
    compose sequence_a_vec (vmap f).

  Instance functor_vec {n : nat} : Functor (fun x => vec x n).
  Proof.
    refine {| fmap := fun _ _ f v => vmap f v; |}.
    (*
    - intros.
      rewrite Vector.map_id.
      reflexivity.
    - intros A B C g h [| x xs].
      + reflexivity.
      + simpl.
        f_equal.
        rewrite Vector.map_map.
        reflexivity.
     *)
  Defined.

  Instance traversable_vec {n : nat} : Traversable (fun x => vec x n).
  Proof.
    refine {| traverse := fun _ _ _ _ _ => traverse_vec;
              sequence_a := fun _ _ _ _ => sequence_a_vec;
           |}.
  Defined.

End Vector.

Module General.

  Definition map_m {A B : Type} {T : Type -> Type} {M : Type -> Type} `{Monad M} `{Traversable T}
             (f : A -> M B) (l : T A) : M (T B) := traverse f l.

End General.

Module MonadNotationBase.

  Delimit Scope monad_scope with monad.

  Notation "c >>= f" := (@bind _ _ _ _ _ _ c f) (at level 58, left associativity) : monad_scope.
  Notation "e1 ;;; e2" := (@bind _ _ _ _ _ _ e1%monad (fun _ => e2%monad))%monad
                                                                        (at level 63, right associativity) : monad_scope.

End MonadNotationBase.

Module MonadNotation.

  Export MonadNotationBase.

  Notation "x <- c1 ;;; c2" := (@bind _ _ _ _ _ _ c1 (fun x => c2))
                                 (at level 63, c1 at next level, right associativity) : monad_scope.

  Notation "' pat <- c1 ;;; c2" :=
    (@bind _ _ _ _ _ _ c1 (fun x => match x with pat => c2 end))
      (at level 63, pat pattern, c1 at next level, right associativity) : monad_scope.

End MonadNotation.


From logrel_heaplang_sessions Require Export lty ltyping split copy.
From iris.heap_lang Require Export lifting metatheory.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import notation proofmode.

Section types.
  Context `{heapG Σ}.

  (* I'm guessing the postcondition doesn't need an additional later
  for contractiveness since the WP already has one? *)
  Definition lty_arr (A1 A2 : lty Σ) : lty Σ := Lty (λ w,
    ∀ v, ▷ A1 v -∗ WP App w v {{ A2 }})%I.
End types.

Notation "A → B" := (lty_copy (lty_arr A B)) : lty_scope.
Infix "⊸" := lty_arr (at level 20, right associativity) : lty_scope.

Section properties.
  Context `{heapG Σ}.

  (* TODO: There's probably a cleaner way to do this *)
  Global Instance lty_arr_contractive n : Proper (dist_later n ==> dist_later n ==> dist n) lty_arr.
  Proof.
    intros A A' ? B B' ?.
    apply lty_ne.
    intros f.
    f_equiv.
    intros w.
    f_equiv.
    - by f_contractive.
    - apply wp_contractive.
      { apply _. }
      intros q.
      destruct n as [|n'].
      + done.
      + by simpl.
  Qed.

  Global Instance lty_arr_ne : NonExpansive2 (@lty_arr Σ _).
  Proof. solve_proper. Qed.

  Lemma ltyped_var Γ (x : string) A :
    Γ !! x = Some A → Γ ⊨ x : A.
  Proof.
    iIntros (HΓx vs) "HΓ /=".
    iDestruct (env_ltyped_lookup with "HΓ") as (v ->) "HA"; first done.
    by iApply wp_value.
  Qed.

  Lemma ltyped_app Γ Γ1 Γ2 e1 e2 A1 A2 :
    env_split Γ Γ1 Γ2 →
    (Γ1 ⊨ e1 : A1 ⊸ A2) → (Γ2 ⊨ e2 : A1) →
    Γ ⊨ e1 e2 : A2.
  Proof.
    intros Hsplit H1 H2.
    iIntros (vs) "HΓ /=".
    iPoseProof (Hsplit with "HΓ") as "[HΓ1 HΓ2]".
    iPoseProof H1 as "H1".
    iPoseProof H2 as "H2".
    wp_apply (wp_wand with "(H2 [HΓ2 //])").
    iIntros (v) "HA1".
    wp_apply (wp_wand with "(H1 [HΓ1 //])").
    iIntros (f) "Hf". iApply ("Hf" $! v with "HA1").
  Qed.

  Lemma ltyped_lam Γ x e A1 A2 :
    (binder_insert x A1 Γ ⊨ e : A2) →
    Γ ⊨ (λ: x, e) : A1 ⊸ A2.
  Proof.
    intros He.
    iPoseProof He as "He".
    iIntros (vs) "HΓ /=". wp_pures.
    iIntros (v) "HA1". wp_pures.
    iSpecialize ("He" $! (binder_insert x v vs) with "[HΓ HA1]").
    { iApply (env_ltyped_insert with "[HA1 //] [HΓ //]"). }
    destruct x as [|x]; rewrite /= -?subst_map_insert //.
  Qed.

  (* The first version of this had Γ ⊨ f : A1 → A2 with f : val, but
  it seemed strange to me that substitution does nothing to values,
  because f is probably a closure and might contain free
  variables. *)
  Lemma ltyped_rec Γ Γ' f x e A1 A2:
    env_copy Γ Γ' →
    (binder_insert f (A1 → A2)%lty (binder_insert x A1 Γ') ⊨ e : A2) →
    Γ ⊨ (rec: f x := e) : A1 → A2.
  Proof.
    intros Hcopy He.
    iPoseProof He as "He".
    iIntros (vs) "HΓ /=". wp_pures.
    iPoseProof (Hcopy with "HΓ") as "#HΓ'".
    iClear "HΓ". iLöb as "IH".
    iModIntro.
    iIntros (v) "HA1". wp_pures. set (r := RecV f x _).
    iSpecialize ("He" $! (binder_insert f r (binder_insert x v vs)) with "[HΓ' HA1]").
    { iApply (env_ltyped_insert with "IH"). iApply (env_ltyped_insert with "[HA1] [HΓ']").
      - iFrame "HA1".
      - iFrame "HΓ'". } (* Why doesn't // work here for env_ltyped_insert premises? *)
    destruct x as [|x], f as [|f]; rewrite /= -?subst_map_insert //.
    destruct (decide (x = f)) as [->|].
    - by rewrite subst_subst delete_idemp insert_insert -subst_map_insert.
    - rewrite subst_subst_ne // -subst_map_insert.
      by rewrite -delete_insert_ne // -subst_map_insert.
  Qed.

End properties.


Require Export Limits.Terminal.

Lemma bot_limit (C: Category): ex_colim 0 C <-> inhabited (BotCategory.mixin_of C).
Proof.
  rewrite <- ex_lim_co.
  rewrite (proj2 (iso_0 (co 0))).
  rewrite top_limit.
  split.
  1, 2: intros [m].
  all: constructor.
  apply BotCo_mixin, m.
  apply (CoTop_mixin (BotCategory.Pack C m)).
  apply coZero2Zero.
Qed.


Require Import VST.floyd.proofauto.
Require Import apile.
Require Import spec_stdlib.
Require Import PileModel.

(*Apile's predicate bundle is similar to the Onepile's bundle.*)
Record APileAPD := {
  apile: list Z -> globals -> mpred
}.

Local Open Scope assert.

Section ApileASI.
Variable M: MallocFreeAPD.
Variable APILE:APileAPD.

Definition Apile_add_spec :=
 DECLARE _Apile_add
 WITH n: Z, sigma: list Z, gv: globals
 PRE [ tint  ]
    PROP(0 <= n <= Int.max_signed)
    PARAMS (Vint (Int.repr n)) GLOBALS (gv)
    SEP(apile APILE sigma gv; mem_mgr M gv)
 POST[ tvoid ]
    PROP() LOCAL()
    SEP(apile APILE (n::sigma) gv; mem_mgr M gv).

Definition Apile_count_spec :=
 DECLARE _Apile_count
 WITH sigma: list Z, gv: globals
 PRE [  ]
    PROP(0 <= sumlist sigma <= Int.max_signed)
    PARAMS () GLOBALS (gv)
    SEP(apile APILE sigma gv; mem_mgr M gv)
 POST[ tint ]
      PROP()
      LOCAL(temp ret_temp (Vint (Int.repr (sumlist sigma))))
      SEP(apile APILE sigma gv; mem_mgr M gv).

Definition ApileASI:funspecs := [ Apile_add_spec; Apile_count_spec].

End ApileASI.


Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.ExtensionTactic.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.
Import CoqPropInLogicNotation.
Import SeparationLogicNotation.

Section DerivedRules.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {Gamma: Provable L}
        {minAX: MinimumAxiomatization L Gamma}
        {andpAX: AndAxiomatization L Gamma}
        {orpAX: OrAxiomatization L Gamma}
        {falsepAX: FalseAxiomatization L Gamma}
        {inegpAX: IntuitionisticNegAxiomatization L Gamma}
        {iffpAX: IffAxiomatization L Gamma}
        {truepAX: TrueAxiomatization L Gamma}
        {sepconAX: SepconAxiomatization L Gamma}.

Lemma provable_sepcon_andp_left: forall (x y z: expr),
  |-- (x && y) * z --> (x * z) && (y * z).
Proof.
  intros.
  apply solve_impp_andp.
  + apply sepcon_mono.
    - apply andp_elim1.
    - apply provable_impp_refl.
  + apply sepcon_mono.
    - apply andp_elim2.
    - apply provable_impp_refl.
Qed.

Lemma provable_sepcon_andp_right: forall (x y z: expr),
  |-- x * (y && z) --> (x * y) && (x * z).
Proof.
  intros.
  rewrite !(sepcon_comm_impp x), <- !(sepcon_comm_impp _ x).
  apply provable_sepcon_andp_left.
Qed.

Lemma provable_truep_sepcon_truep {ExtsGamma: ExtSeparationLogic L Gamma}:
  |-- TT * TT <--> TT.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply solve_impp_elim_left.
    apply truep_intros.
  + apply sepcon_ext.
Qed.

Section CoqProp.

Context {coq_prop_L: CoqPropLanguage L}
        {sepcon_coq_prop_AX: SepconCoqPropAxiomatization L Gamma}.

Lemma prop_sepcon_andp2: forall P Q R,
 |-- Q * (R && !! P) <--> !! P && (Q * R).
Proof.
  intros.
  rewrite ! (sepcon_comm Q).
  rewrite (andp_comm R).
  apply prop_andp_sepcon1; auto.
Qed.

Lemma prop_sepcon_andp1: forall P Q R,
  |-- Q * (!! P && R) <--> !! P && (Q * R).
Proof.
  intros.
  rewrite !(sepcon_comm Q).
  apply prop_andp_sepcon1; auto.
Qed.

Lemma prop_andp_sepcon2: forall P Q R,
  |-- Q && !! P * R <--> !! P && (Q * R).
Proof.
  intros.
  rewrite (andp_comm Q).
  apply prop_andp_sepcon1; auto.
Qed.

End CoqProp.

(* TODO: move this to TheoryOfSeparationAxioms. *)
Lemma GC_Ext_Classical_collapse_aux
      {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
      {cpGamma: ClassicalAxiomatization L Gamma}
      {gcsGamma: GarbageCollectSeparationLogic L Gamma}
      {ExtsGamma: ExtSeparationLogic L Gamma}:
  forall (x: expr), |-- x --> x * x.
Proof.
  intros.
  rewrite (sepcon_ext x) at 1.
  assert (|-- TT --> x || ~~ x) by (apply solve_impp_elim_left, excluded_middle).
  rewrite H; clear H.
  rewrite sepcon_orp_distr_l_iffp.
  apply solve_orp_impp; [apply provable_impp_refl |].
  rewrite <- (andp_dup (x * ~~ x)).
  rewrite sepcon_elim1 at 1.
  rewrite sepcon_elim2 at 1.
  AddSequentCalculus.
  rewrite provable_derivable.
  rewrite <- deduction_theorem.
  apply deduction_falsep_elim.
  apply deduction_modus_ponens with x.
  + apply deduction_andp_elim1 with (~~x).
    solve_assum.
  + apply deduction_andp_elim2 with x.
    rewrite <- (negp_fold_unfold x).
    solve_assum.
Qed.

(* TODO: move this to TheoryOfSeparationAxioms. *)
Theorem GC_Ext_Classical_collapse
        {sepcon_orp_AX: SepconOrAxiomatization L Gamma}
        {cpAX: ClassicalAxiomatization L Gamma}
        {gcsAX: GarbageCollectSeparationLogic L Gamma}
        {ExtsAX: ExtSeparationLogic L Gamma}:
  forall (x y: expr), |-- x * y <--> x && y.
Proof.
  intros.
  apply solve_iffp_intros.
  + apply solve_impp_andp.
    - apply sepcon_elim1.
    - apply sepcon_elim2.
  + rewrite (GC_Ext_Classical_collapse_aux (x && y)).
    apply sepcon_mono.
    - apply andp_elim1.
    - apply andp_elim2.
Qed.

Context {empL: EmpLanguage L}
        {empAX: EmpAxiomatization L Gamma}.

Lemma derivable_emp {gcsGamma: GarbageCollectSeparationLogic L Gamma}:
  forall (x y: expr), |-- emp.
Proof.
  intros.
  rewrite <- (sepcon_elim2 TT emp).
  rewrite sepcon_emp.
  apply truep_intros.
Qed.

End DerivedRules.


(**  Mathematical model of the causal memory implementation
     from "Causal memory: definitions, implementation, and programming"
     (https://link.springer.com/article/10.1007/BF01784241).*)

From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.ccddb.spec Require Import base.
From aneris.examples.ccddb.model Require Export model_lsec.

Section Local_history_valid.
  Context `{!anerisG Mdl Σ, !DB_params}.

  Definition DBM_lhst_ext (s : gset apply_event) :=
    ∀ e e', e ∈ s → e' ∈ s → ae_time e = ae_time e' → e = e'.

  Definition DBM_lhst_times (s : gset apply_event) :=
    ∀ e, e ∈ s → length e.(ae_time) = length DB_addresses.

  Definition DBM_lhst_origs (i : nat) (s : gset apply_event) :=
    (∀ e, e ∈ s → e.(ae_orig) < length DB_addresses).

  Definition DBM_lhst_lsec_valid (i : nat) (s : gset apply_event) :=
    (∀ j, j < length DB_addresses → DBM_lsec_valid i j s).

  Definition DBM_lhst_seqids (s : gset apply_event) :=
    ∀ e, e ∈ s → e.(ae_seqid) <= size s.

  Definition DBM_lhst_keys (s : gset apply_event) :=
    ∀ e, e ∈ s → e.(ae_key) ∈ DB_keys.

  Record DBM_lhst_valid (i : nat) (s : gset apply_event) : Prop := {
    DBM_LHV_bound_at: i < length DB_addresses;
    DBM_LHV_times: DBM_lhst_times s;
    DBM_LHV_ext: DBM_lhst_ext s;
    DBM_LHV_origs: DBM_lhst_origs i s;
    DBM_LHV_keys: DBM_lhst_keys s;
    DBM_LHV_secs_valid: DBM_lhst_lsec_valid i s;
    DBM_LHV_seqids: DBM_lhst_seqids s;
}.

  Global Arguments DBM_LHV_bound_at {_ _} _.
  Global Arguments DBM_LHV_times {_ _} _.
  Global Arguments DBM_LHV_ext {_ _} _.
  Global Arguments DBM_LHV_origs {_ _} _.
  Global Arguments DBM_LHV_secs_valid {_ _} _.
  Global Arguments DBM_LHV_seqids {_ _} _.
  Global Arguments DBM_LHV_keys {_ _} _.

  Lemma in_lhs_time_component e k i s :
    DBM_lhst_valid i s →
    k < length DB_addresses →
    e ∈ s →
    is_Some (e.(ae_time) !! k).
  Proof.
    intros ???; eapply lookup_lt_is_Some_2; erewrite DBM_LHV_times; eauto.
  Qed.

  Lemma DBM_lsec_empty i s:
    DBM_lhst_valid i s →
    ∀ j', j' < length DB_addresses →
          DBM_lsec j' s = ∅ ↔ ∀ e, e ∈ s → e.(ae_time) !! j' = Some 0.
  Proof.
    intros Hvli j' Hj'lt.
    split.
    - intros Hjs e Hes.
      pose proof (in_lsec_orig e s Hes) as Hesec.
      pose proof (DBM_LHV_origs Hvli e Hes) as Heorig.
      destruct (lookup_lt_is_Some_2 (ae_time e) j') as [k Hk].
      { rewrite (DBM_LHV_times Hvli) //. }
      rewrite Hk.
      destruct (decide (j' = e.(ae_orig))) as [->|].
      { by rewrite Hjs in Hesec. }
      pose proof (DBM_LHV_secs_valid Hvli e.(ae_orig) Heorig) as Hesecvl.
      destruct (decide (i = e.(ae_orig))) as [->|].
      { pose proof (DBM_LSV_caus_refl Hesecvl j' e Hj'lt) as Hvlrefl.
        rewrite Hk /= in Hvlrefl.
        rewrite DBM_lsec_latest_in_frame_empty in Hvlrefl; last done.
        apply Hvlrefl; auto. }
      pose proof (DBM_LSV_caus Hesecvl j' e Hj'lt) as Hvlirrefl.
      rewrite Hk /= in Hvlirrefl.
      rewrite DBM_lsec_latest_in_frame_empty in Hvlirrefl; last done.
      f_equal; symmetry; apply le_n_0_eq.
      apply Hvlirrefl; auto.
    - destruct (decide (DBM_lsec j' s = ∅)) as [|Hne]; first done.
      apply set_choose_L in Hne as [x Hx].
      pose proof (DBM_LHV_secs_valid Hvli j' Hj'lt) as Hesecvl.
      intros He.
      pose proof (in_lsec_in_lhst _ _ _ Hx) as Hxs.
      apply He in Hxs.
      destruct (DBM_LSV_strongly_complete (DBM_LHV_times Hvli) Hj'lt Hesecvl 0)
        as [_ []]; eauto with lia.
  Qed.

  Definition lsec_sup (j : nat) (s: gset apply_event) : nat :=
    nat_sup (omap (λ e, e.(ae_time) !! j) (elements (DBM_lsec j s))).

  Lemma lsec_sup_empty j : lsec_sup j ∅ = 0.
  Proof. by rewrite /lsec_sup DBM_lsec_of_empty elements_empty /=. Qed.

  Lemma elem_of_lsec_lsec_sup_length e i j s :
    DBM_lhst_valid i s →
    j < length DB_addresses →
    e ∈ DBM_lsec j s → length (elements (DBM_lsec j s)) = lsec_sup j s.
  Proof.
    intros Hvl Hj He.
    assert (∃ e', e' ∈ DBM_lsec j s ∧
                  (e'.(ae_time) !! j = Some (lsec_sup j s))) as
        (e' & He'1 & He'2).
    { assert
        (lsec_sup j s ∈ (omap (λ e, e.(ae_time) !! j)
                              (elements (DBM_lsec j s)))) as Hsup.
      { edestruct (in_lhs_time_component e j) as [p Hp];
          eauto using in_lsec_in_lhst.
        eapply (nat_sup_elem_of p).
        apply elem_of_list_omap.
          by exists e; split; first apply elem_of_elements. }
      apply elem_of_list_omap in Hsup as (?&?%elem_of_elements&?); eauto. }
    apply Nat.le_antisymm.
    - edestruct le_lt_dec as [Hle|Hlt]; first exact Hle.
      destruct (DBM_LSV_comp (DBM_LHV_secs_valid Hvl j Hj) (S (lsec_sup j s))) as
          (e'' & He''1 & He''2); first lia.
      assert (S (lsec_sup j s) ≤ lsec_sup j s); last lia.
      apply nat_sup_UB.
      apply elem_of_list_omap.
        by eexists; split; first apply elem_of_elements.
    - apply (DBM_LSV_strongly_complete
               (DBM_LHV_times Hvl) Hj (DBM_LHV_secs_valid Hvl j Hj)); eauto.
  Qed.

Lemma lsec_lsup_length i j s :
    DBM_lhst_valid i s →
    j < length DB_addresses →
    length (elements (DBM_lsec j s)) = lsec_sup j s.
  Proof.
    intros Hvl Hj.
    destruct (decide (DBM_lsec j s ≡ ∅)) as [Hempty| Hex].
    - rewrite /lsec_sup. simplify_eq. rewrite Hempty. set_solver.
    - apply set_choose in Hex as (e' & He').
      eapply (elem_of_lsec_lsec_sup_length e'); eauto.
  Qed.

  Lemma DBM_lsec_causality_lemma i s e p q r :
    r < length DB_addresses →
    DBM_lhst_valid i s →
    e ∈ s →
    0 < p →
    p ≤ q →
    e.(ae_time) !! r = Some q →
    ∃ e', e' ∈ DBM_lsec r s ∧ e'.(ae_time) !! r = Some p.
  Proof.
    intros Hr His He Hp Hpq Herq.
    destruct (decide (r = e.(ae_orig))) as [Heq|Hreor].
    { apply (DBM_LSV_comp (DBM_LHV_secs_valid His r Hr)).
      split; first lia.
      apply (Nat.le_trans _ q); first done.
      apply (DBM_LSV_strongly_complete
               (DBM_LHV_times His) Hr (DBM_LHV_secs_valid His r Hr)).
      exists e; split; last done.
        by rewrite Heq; apply in_lsec_orig. }
    assert (DBM_lsec r s ≠ ∅) as Hrs.
    { rewrite (DBM_lsec_empty i); auto.
      intros Hz.
      specialize (Hz e He); rewrite Herq in Hz; simplify_eq; lia. }
    assert (∃ e' p', e' ∈ DBM_lsec r s ∧ e'.(ae_time) !! r = Some p')
      as (e' & p' & He' & Hp').
    { apply set_choose_L in Hrs as (e' & He').
      edestruct (in_lhs_time_component e') as [p' Hp'];
        eauto using in_lsec_in_lhst. }
    assert (1 ≤ p').
    { eapply DBM_LSV_strongly_complete; [|done| |by eauto].
      - by eapply DBM_LHV_times; eauto.
      - by eapply DBM_LHV_secs_valid; eauto. }
    assert (p' ≤ lsec_sup r s).
    { apply nat_sup_UB.
      apply elem_of_list_omap.
      exists e'; split; first apply elem_of_elements; eauto. }
    destruct (decide (p <= lsec_sup r s)).
    - assert (1 ≤ p ∧ p <= strings.length (elements (DBM_lsec r s)))
        as Hpbounds.
      { split; first lia.
        erewrite elem_of_lsec_lsec_sup_length; eauto with lia. }
      apply (DBM_LSV_comp (DBM_LHV_secs_valid His r Hr)); eauto.
    - assert (lsec_sup r s < p) as HpSup by lia.
      assert (q <= lsec_sup r s); last lia.
      pose proof (DBM_LHV_origs His e He) as Helsec.
      pose proof (DBM_LSV_caus (DBM_LHV_secs_valid His e.(ae_orig) Helsec)
                               r e Hr Hreor) as Hq.
      rewrite Herq /= in Hq.
      etrans; first by apply Hq, in_lsec_orig.
      apply nat_sup_mono.
      intros a; rewrite !elem_of_list_omap;
        intros (?&[? ?]%elem_of_list_filter&?); eauto.
  Qed.

  Lemma empty_lhst_valid i :
    i < length DB_addresses →
    DBM_lhst_valid i ∅.
  Proof.
    split; [done|done|done|done|done| |done].
    intros ? ?; apply sections_empty_valid; done.
  Qed.

  Definition Observe_lhst (s : gset apply_event) : apply_event :=
    sup ae_seqid lt (ApplyEvent "" #() inhabitant 0 0) (elements s).

  Lemma Observe_lhst_max_seqid s e :
    (∀ e', e' ∈ s → e' ≠ e → e'.(ae_seqid) < e.(ae_seqid)) →
    e ∈ s →
    e.(ae_seqid) > 0 →
    Observe_lhst s = e.
  Proof.
    intros Hs Hes Heseq.
    assert (e.(ae_seqid) ≤ (Observe_lhst s).(ae_seqid)) as Hseqids.
    { apply (sup_UB ae_seqid lt le); last set_solver; eauto with lia. }
    assert (Observe_lhst s = (ApplyEvent "" #() inhabitant 0 0) ∨
            Observe_lhst s ∈ s) as Hobs.
    { rewrite -elem_of_elements.
      apply find_one_maximal_eq_or_elem_of. }
    destruct Hobs as [Hobs| Hobs].
    - rewrite Hobs in Hseqids; simpl in *; lia.
    - destruct (decide (Observe_lhst s = e)) as [|Hneq]; first done.
      specialize (Hs _ Hobs Hneq); lia.
  Qed.

  Lemma valid_lhst_restrict_key_out i s k :
    DBM_lhst_valid i s → k ∉ DB_keys → restrict_key k s = ∅.
  Proof.
    intros Hvl Hk.
    apply set_eq; intros a; split; last done.
    apply elem_of_subseteq; intros x.
    rewrite elem_of_filter.
    intros [<- Hx%(DBM_LHV_keys Hvl)]; done.
  Qed.

End Local_history_valid.


Require Import POCS.
Require Import StatDb.StatDbAPI.
Require Import Variables.VariablesAPI.

Import Vars.
Import StatDB.

Module StatDB.

  Section Implementation.

    Variable (vars : Interface Vars.API).

    Definition add (v : nat) : prog unit :=
      sum <- Prim vars (Read VarSum);
      count <- Prim vars (Read VarCount);
      _ <- Prim vars (Write VarSum (sum + v));
      _ <- Prim vars (Write VarCount (count + 1));
      Ret tt.

    Definition mean : prog (option nat) :=
      (* Your solutions here *)
      Ret (Some 0).

    Definition init : prog InitResult :=
      _ <- Prim vars (Write VarCount 0);
      _ <- Prim vars (Write VarSum 0);
      Ret Initialized.

    Definition statdb_op_impl T (op: StatDB.Op T) : prog T :=
      match op with
      | Add v => add v
      | Mean => mean
      end.

    Definition impl : InterfaceImpl StatDB.Op :=
      {| op_impl := statdb_op_impl;
         recover_impl := Ret tt;
         init_impl := then_init (iInit vars) init; |}.

    Definition statdb_abstraction (vars_state : Vars.State) (statdb_state : StatDB.State) : Prop :=
      StateCount vars_state = length statdb_state /\
      StateSum vars_state = fold_right plus 0 statdb_state.

    Definition abstr : Abstraction StatDB.State :=
      abstraction_compose
        (interface_abs vars)
        {| abstraction := statdb_abstraction |}.

    Definition statdb : Interface StatDB.API.
      unshelve econstructor.
      - exact impl.
      - exact abstr.
      - destruct op.

        + lift_world.
          prog_spec_symbolic_execute inv_step.
          solve_final_state.

          unfold statdb_abstraction in *.
          simpl in *.
          intuition.

        + (* Prove that your implementation of [mean] refines StatDbAPI.man *)
          pocs_admit.

      - cannot_crash.
      - eapply then_init_compose; eauto.
        prog_spec_symbolic_execute inv_step.

        solve_final_state.

        instantiate (1 := nil).
        simpl; auto.
        simpl; auto.
        reflexivity.

      Unshelve.
      all: eauto.
    Defined.

  End Implementation.

End StatDB.

Print Assumptions StatDB.statdb.


(** Boolean-valued total orders as a [Class] *)

From Coq Require Import Bool PeanoNat Wf_nat Lia List Orders.
From OLlibs Require Import funtheory.

Set Implicit Arguments.

(** * Class of Boolean-valued total orders *)

Definition brelation A := A -> A -> bool.

Class BOrder := {
  car : Type;
  leb : brelation car;
  total a b : leb a b = false -> leb b a = true;
  asym a b : leb a b = true -> leb b a = true -> a = b;
  trans a b c : leb a b = true -> leb b c = true -> leb a c = true}.
Coercion car : BOrder >-> Sortclass.

(** ** Equivalence with [UsualOrderedTypeFull] *)
Module Type ModBOrder.
  Parameter t : BOrder.
End ModBOrder.

Module ModBOrder_as_UsualOrderedTypeFull (B : ModBOrder) : UsualOrderedTypeFull.

  Definition t := @car B.t.
  Definition eq := @eq B.t.
  Definition eq_equiv : Equivalence eq := eq_equivalence.
  #[local] Coercion is_true : bool >-> Sortclass.
  Definition lt x y := @leb B.t x y /\ x <> y.

  Lemma lt_strorder : StrictOrder lt.
  Proof.
  split.
  - intros a [Hleq Hneq]. apply Hneq. reflexivity.
  - intros a b c [Hleq1 Hneq1] [Hleq2 Hneq2]. split.
    + eapply trans; eassumption.
    + intros ->.
      destruct (leb b c) eqn: Heqbb1; [ destruct (leb c b) eqn:Heqbb2 | ].
      * apply asym in Heqbb1 as ->; [ | assumption ].
        apply Hneq1. reflexivity.
      * discriminate Hleq1.
      * discriminate Hleq2.
  Qed.

  Lemma lt_compat : Proper (eq==>eq==>iff) lt.
  Proof. intros a b H1 c d H2. unfold eq in H1, H2. subst. reflexivity. Qed.

  Definition compare x y := if @leb B.t x y then (if leb y x then Eq else Lt) else Gt.

  Lemma compare_spec x y : CompSpec eq lt x y (compare x y).
  Proof.
  unfold compare.
  destruct (leb x y) eqn:Hlebx; [ destruct (leb y x) eqn:Hleby | ]; constructor.
  - apply asym; assumption.
  - split; [ assumption | ].
    intros ->.
    rewrite Hlebx in Hleby. discriminate Hleby.
  - assert (Ht := total _ _ Hlebx).
    split; [ assumption | ].
    intros ->.
    rewrite Ht in Hlebx. discriminate Hlebx.
  Qed.

  Lemma eq_dec x y : {eq x y} + {eq x y -> False}.
  Proof.
  destruct (leb x y) eqn:Heq1, (leb y x) eqn:Heq2.
  - destruct (asym _ _ Heq1 Heq2). left. reflexivity.
  - right. intros Heq. unfold eq in Heq. subst.
    rewrite Heq1 in Heq2. discriminate Heq2.
  - right. intros Heq. unfold eq in Heq. subst.
    rewrite Heq1 in Heq2. discriminate Heq2.
  - apply total in Heq1. rewrite Heq1 in Heq2. discriminate Heq2.
  Qed.

  Definition le x y := is_true (@leb B.t x y).

  Lemma le_lteq x y : le x y <-> lt x y \/ eq x y.
  Proof.
  split.
  - intros Hle.
    destruct (eq_dec x y).
    + right. assumption.
    + left. split; assumption.
  - intros [[Hle Heq] | ->]; [ assumption | ].
    destruct (leb y y) eqn:Heq2.
    + assumption.
    + exfalso.
      assert (Heq3 := total _ _ Heq2).
      rewrite Heq2 in Heq3. discriminate Heq3.
  Qed.

End ModBOrder_as_UsualOrderedTypeFull.

Module UsualOrderedTypeFull_as_BOrder (T : UsualOrderedTypeFull).

  Definition leb x y :=
  match T.compare x y with
  | Gt => false
  | _  => true
  end.

  Lemma leb_le x y : leb x y = true -> T.le x y.
  Proof.
  unfold leb. intros Hcmp.
  apply T.le_lteq.
  destruct (T.compare_spec x y) as [ Heq | Hlt | Hgt ].
  - right. assumption.
  - left. assumption.
  - discriminate Hcmp.
  Qed.

  Lemma le_leb x y : T.le x y -> leb x y = true.
  Proof.
  intros Hle. unfold leb.
  destruct (T.compare_spec x y) as [ Heq | Hlt | Hgt]; [ reflexivity | reflexivity | ].
  destruct (StrictOrder_Irreflexive x).
  apply T.le_lteq in Hle as [ Hlt | -> ].
  - transitivity y; assumption.
  - assumption.
  Qed.

  Lemma nleb_lt x y : leb x y = false -> T.lt y x.
  Proof.
  unfold leb. intros Hleb.
  destruct (T.compare_spec x y) as [ Heq | Hlt | Hgt]; [ discriminate Hleb | discriminate Hleb | assumption ].
  Qed.

  Lemma lt_nleb x y : T.lt y x -> leb x y = false.
  Proof.
  intros Hlty.
  unfold leb.
  destruct (T.compare_spec x y) as [ -> | Hlt | Hgt]; [ | | reflexivity ].
  - apply StrictOrder_Irreflexive in Hlty as [].
  - apply (StrictOrder_Transitive _ _ _ Hlty) in Hlt.
    apply StrictOrder_Irreflexive in Hlt as [].
  Qed.

  Lemma to_BOrder : BOrder.
  Proof.
  split with T.t leb.
  - intros a b Hf.
    apply nleb_lt in Hf.
    apply le_leb.
    apply T.le_lteq.
    left ; assumption.
  - intros a b H1 H2.
    apply leb_le in H1.
    apply leb_le in H2.
    apply T.le_lteq in H1.
    apply T.le_lteq in H2.
    destruct H1 as [H1|H1], H2 as [H2|H2]; auto.
    apply (StrictOrder_Transitive _ _ _ H2) in H1.
    apply StrictOrder_Irreflexive in H1.
    destruct H1.
  - intros a b c [ H1 | -> ]%leb_le%T.le_lteq [ H2 | -> ]%leb_le%T.le_lteq; apply le_leb, T.le_lteq.
    + left. transitivity b; assumption.
    + left. assumption.
    + left. assumption.
    + right. reflexivity.
  Qed.

End UsualOrderedTypeFull_as_BOrder.

Module UsualOrderedTypeFull_as_ModBOrder (T : UsualOrderedTypeFull) : ModBOrder.
  Module TBOrder := UsualOrderedTypeFull_as_BOrder T.
  Definition t := TBOrder.to_BOrder.
End UsualOrderedTypeFull_as_ModBOrder.

(** * [BOrder] structure over [nat]. *)
#[export] Instance border_nat : BOrder.
Proof.
split with nat Nat.leb; intros a b.
- intros Hleb.
  case (Nat.compare_spec a b); intros Ho; apply Nat.leb_le; [ lia | | lia ].
  exfalso.
  eapply or_introl, Nat.le_lteq, Nat.leb_le in Ho.
  rewrite Ho in Hleb. discriminate Hleb.
- intros Hleb%Nat.leb_le Hleb2%Nat.leb_le. lia.
- intros c Hleb%Nat.leb_le Hleb2%Nat.leb_le. apply Nat.leb_le. lia.
Defined.

Lemma border_inj A B (f : A -> @car B) (Hi : injective f) : BOrder.
Proof.
split with A (fun x y => leb (f x) (f y)); intros.
- apply total. assumption.
- apply Hi, asym; assumption.
- apply trans with (f b); assumption.
Defined.

(** * Sorted lists over [BOrder] *)

(** ** Insertion sort *)

Fixpoint insert B (a : @car B) l :=
match l with
| nil => a :: nil
| b :: t => if (leb a b) then a :: b :: t
                         else b :: (insert B a t)
end.
Arguments insert {_} _ _.

Lemma insert_insert B : forall (x y : @car B) l,
  insert y (insert x l) = insert x (insert y l).
Proof.
induction l as [|a l IHl]; cbn.
- destruct (leb x y) eqn:Heqbb1, (leb y x) eqn:Heqbb2; try reflexivity.
  + apply (asym _ _ Heqbb1) in Heqbb2 as ->. reflexivity.
  + apply total in Heqbb1. rewrite Heqbb1 in Heqbb2. discriminate Heqbb2.
- destruct (leb x a) eqn:Heqbb1, (leb y a) eqn:Heqbb2; cbn.
  + destruct (leb x y) eqn:Heqbb, (leb y x) eqn:Heqbb'; rewrite ? Heqbb1, ? Heqbb2; try reflexivity.
    * apply (asym _ _ Heqbb') in Heqbb as ->. reflexivity.
    * apply total in Heqbb'. rewrite Heqbb' in Heqbb. discriminate Heqbb.
  + destruct (leb y x) eqn:Heqbb'; rewrite ? Heqbb1, ? Heqbb2; try reflexivity.
    apply (trans _ _ _ Heqbb') in Heqbb1. rewrite Heqbb1 in Heqbb2. discriminate Heqbb2.
  + destruct (leb x y) eqn:Heqbb; rewrite ? Heqbb1, ? Heqbb2; try reflexivity.
    apply (trans _ _ _ Heqbb) in Heqbb2. rewrite Heqbb1 in Heqbb2. discriminate Heqbb2.
  + rewrite Heqbb1, Heqbb2, IHl. reflexivity.
Qed.

(** ** Sorted lists *)

Fixpoint is_sorted B (l : list (@car B)) :=
match l with
| nil => true
| a :: nil => true
| a :: (b :: _) as r => leb a b && is_sorted B r
end.
Arguments is_sorted {_} _.

Lemma is_sorted_tail B a l : @is_sorted B (a :: l) = true -> is_sorted l = true.
Proof. intros Hs. destruct l as [|b l]; [ reflexivity | apply andb_true_iff in Hs; apply Hs ]. Qed.

Definition SortedList B := { m | @is_sorted B m = true }.

Lemma sortedlist_equality B (m1 m2 : SortedList B) : proj1_sig m1 = proj1_sig m2 -> m1 = m2.
Proof.
destruct m1 as [m1' B1], m2 as [m2' B2]. cbn. intros ->.
f_equal. apply (Eqdep_dec.UIP_dec bool_dec).
Qed.

Lemma insert_sorted B a (m : SortedList B) :
  let l := insert a (proj1_sig m) in
    is_sorted l = true /\ l <> nil
 /\ forall c, In c l -> In c (proj1_sig m) \/ c = a.
Proof.
enough (forall s a (m : SortedList B),
  length (proj1_sig m) = s ->
  let l := insert a (proj1_sig m) in
    is_sorted l = true /\ l <> nil
 /\ forall c, In c l -> In c (proj1_sig m) \/ c = a) as Hlen
  by now intros; apply Hlen with (length (proj1_sig m)).
induction s as [s IH] using (well_founded_induction lt_wf).
clear a m; intros a m Hlen l.
destruct m as [l0 Hsort].
destruct l0; repeat split; auto.
- intros [=].
- intros c Hc.
  inversion Hc as [ -> | [] ].
  right. reflexivity.
- unfold l. simpl.
  destruct (leb a c) eqn:Heqbb.
  + now apply andb_true_iff; split.
  + destruct s; inversion Hlen.
    destruct (IH s (le_n _) a (exist _ l0 (is_sorted_tail _ _ _ Hsort)) H0)
      as [Hsort' _].
    apply total in Heqbb.
    destruct l0 ; try (apply andb_true_iff ; split); auto.
    simpl; simpl in Hsort'.
    destruct (leb a c0); apply andb_true_iff; split; auto.
    clear Hlen l. simpl in Hsort.
    apply andb_true_iff in Hsort. apply Hsort.
- intro Heq. unfold l in Heq. simpl in Heq.
  destruct (leb a c); discriminate Heq.
- intros d Hd. unfold l in Hd. simpl in Hd.
  destruct (leb a c).
  + inversion Hd as [ -> | ]; [ right | left ]; trivial.
  + inversion Hd as [ -> | Hin ].
    * left. left. reflexivity.
    * destruct s; inversion Hlen as [ Hlen' ].
      destruct (IH s (le_n _) a (exist _ l0 (is_sorted_tail _ _ _ Hsort)) Hlen') as [_ Hin'].
      apply Hin' in Hin.
      destruct Hin; [ left; apply in_cons | right ]; assumption.
Qed.


(*
 * This file contains useful generic equivalences that can be instantiated.
 *)

(*
 * Useful equivalence for algebraic ornaments in packed form, like
 * { s : sigT (vector T) & projT1 s = n }. See coq/examples/Example.v for use
 * of this eliminator.
 *)
Lemma unpack_generic (I_B : Type) (B : I_B -> Type):
  forall (i_b : I_B), { s : sigT B & projT1 s = i_b } -> B i_b.
Proof.
  intros i_b ss. apply (@eq_rect _ (projT1 (projT1 ss)) _  (projT2 (projT1 ss)) i_b (projT2 ss)).
Defined.

Lemma unpack_generic_inv (I_B : Type) (B : I_B -> Type):
  forall (i_b : I_B), B i_b -> { s : sigT B & projT1 s = i_b }.
Proof.
  intros i_b b. exists (existT _ i_b b). reflexivity.
Defined.

Lemma unpack_generic_section (I_B : Type) (B : I_B -> Type):
  forall i_b s, unpack_generic_inv I_B B i_b (unpack_generic I_B B i_b s) = s.
Proof.
  intros. unfold unpack_generic, unpack_generic_inv.
  induction s. induction x. simpl in *. rewrite <- p.
  reflexivity.
Defined.

Lemma unpack_generic_retraction (I_B : Type) (B : I_B -> Type):
  forall i_b b, unpack_generic I_B B i_b (unpack_generic_inv I_B B i_b b) = b.
Proof.
  intros. reflexivity.
Defined.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               Subtyping_inversion
               Infrastructure.

Require Import List. Import ListNotations.

(* Check Mode *)
Lemma Typing_chk2inf: forall G v A,
    Typing G v Chk A -> exists B, Typing G v Inf B /\ sub B A.
Proof.
  intros G v A Typ.
  inductions Typ; try solve [inverts Val].
  exists.
  split*.
Qed.

Lemma Typing_chk_sub: forall G e A B,
    Typing G e Chk A -> sub A B -> Typing G e Chk B.
Proof.
  intros G e A B H H0.
  inductions H.
  - eapply Typ_sub.
    apply H.
    auto_sub.
Qed.

(* Common Lemmas *)
Lemma Typing_regular_1 : forall e G dir A,
    Typing G e dir A -> lc_exp e.
Proof.
  intros e G dir A H.
  induction H;
    eauto.
Qed.

Lemma Typing_regular_2 : forall G e dir T,
    Typing G e dir T -> uniq G.
Proof.
  intros. induction* H.
  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.

  pick fresh y.
  assert (uniq ((y, A) :: G)) by auto.
  solve_uniq.
Qed.

Lemma Typing_weaken : forall G E F e dir T,
    Typing (E ++ G) e dir T ->
    uniq (E ++ F ++ G) ->
    Typing (E ++ F ++ G) e dir T.
Proof.
  introv Typ; gen F;
    inductions Typ; introv Ok; autos*.
    + (* abs *)
      pick fresh x and apply Typ_abs; eauto.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
    + (* fix *)
      pick fresh x and apply Typ_fix.
      rewrite_env (([(x, A)] ++ E) ++ F ++ G).
      apply~ H0.
      solve_uniq.
Qed.

Lemma Typing_weakening : forall (E F : ctx) e dir T,
    Typing E e dir T ->
    uniq (F ++ E) ->
    Typing (F ++ E) e dir T.
Proof.
  intros.
  rewrite_env (nil ++ F ++ E).
  apply~ Typing_weaken.
Qed.

(** Typing is preserved by substitution. *)

Lemma fv_in_dom: forall G e dir T,
    Typing G e dir T -> fv_exp e [<=] dom G.
Proof.
  intros G e dir T H.
  induction H; simpl; try fsetdec.
  - (* typing_var *)
    apply binds_In in H0.
    fsetdec.
  - (* typing_abs *)
    pick fresh x.
    assert (Fx : fv_exp (e ^ x) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (e ^ x)) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
  - (* typing_fix *)
    pick fresh x.
    assert (Fx : fv_exp (e ^ x) [<=] dom ([(x,A)] ++ G))
      by eauto.
    simpl in Fx.
    assert (Fy : fv_exp e [<=] fv_exp (e ^ x)) by
        eapply fv_exp_open_exp_wrt_exp_lower.
    fsetdec.
Qed.

Lemma value_no_fv : forall v dir T,
    Typing [] v dir T -> fv_exp v [<=] empty.
Proof.
  intro v.
  pose proof (fv_in_dom [] v).
  intuition eauto.
Qed.

Lemma subst_value : forall v T dir z u,
    Typing [] v dir T -> subst_exp u z v = v.
Proof.
  intros v dir T z u Typ.
  lets* Fv: value_no_fv Typ.
  forwards*: subst_exp_fresh_eq.
  rewrite Fv.
  fsetdec.
Qed.

Lemma Typing_subst_2 : forall (E F : ctx) e u S S' dir T (z : atom),
    Typing (F ++ [(z,S)] ++ E) e dir T ->
    Typing E u Inf S' ->
    subsub S' S ->
    exists T', Typing (F ++ E) ([z ~> u] e) dir T' /\ subsub T' T.
Proof.
  introv Typ Typv Subsub.
  remember (F ++ [(z,S)] ++ E) as E'.
  generalize dependent F.
  inductions Typ;
    intros F Eq; subst; simpl; autos*;
      lets Lc  : Typing_regular_1 Typv;
      lets Uni : Typing_regular_2 Typv;
      try solve [exists; split*].
  - (* var *)
    case_if*.
    substs.
    assert (A = S).
    eapply binds_mid_eq; eauto.
    substs.
    exists. split.
    apply~ Typing_weakening. eauto.
    solve_uniq.
    auto.
  - (* abs *)
    exists. split.
    eapply (Typ_abs (union L (singleton z))); eauto.
    intros.
    forwards~(?&?&?): H0 x.
    rewrite_env (([(x, A)] ++ F) ++ [(z, S)] ++ E).
    reflexivity.
    (* lc_e_abs_exists *)
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply subsub2sub in H3.
    forwards*: Typing_chk_sub H2 H3.
    auto.
  - (* app *)
    forwards* (?&?&?): IHTyp1.
    forwards* (?&?&?): IHTyp2.
    inverts H.
    + (* arrow *)
      apply subsub2sub in H3.
      inverts H1.
    * exists B. split*.
      forwards~: Typing_chk_sub H2 H3.
      forwards*: Typ_app H.
    * exists A2. split*.
      assert (HS: sub x0 A1) by auto_sub.
      forwards~: Typing_chk_sub H2 HS.
      forwards*: Typ_app H.
    * (* toplike *)
      exists t_top. split*.
      ** applys* Typ_app H0.
         applys* Typing_chk_sub H2.
      ** inverts~ H.
    + (* T v *)
      exists t_top. split*.
      applys* Typ_app H0.
      inverts~ H1; inverts~ H3.
  - (* merge *)
    forwards* (?&?&?): IHTyp1.
    forwards* (?&?&?): IHTyp2.
    exists (t_and x x0). split*.
    apply~ Typ_merge.
    eapply subsub_disjointSpec_l. eassumption.
    eapply subsub_disjointSpec_r. eassumption.
    assumption.
  - (* anno *)
    exists A. split*.
    apply Typ_anno.
    forwards* (?&?&?): IHTyp.
    apply subsub2sub in H0.
    forwards*: Typing_chk_sub H H0.
  - (* fix *)
    exists A. split*.
    pick fresh x and apply Typ_fix.
    rewrite subst_exp_open_exp_wrt_exp_var; auto.
    forwards* (?&?&?): H0.
    rewrite_env (([(x, A)] ++ F) ++ [(z, S)] ++ E).
    reflexivity.
    rewrite_env (([(x, A)] ++ F) ++ E).
    apply subsub2sub in H2.
    forwards*: Typing_chk_sub H1 H2.
  - (* mergev *)
    lets Eq1: ((subst_value _ _ _ z u) Typ1).
    lets Eq2: ((subst_value _ _ _ z u) Typ2).
    rewrite Eq1.
    rewrite Eq2.
    exists (t_and A B). split*.
  - (* sub *)
    forwards* (?&?&?): IHTyp.
    exists B. split*.
    apply subsub2sub in H1.
    assert (sub x B) by auto_sub.
    forwards*: Typ_sub H0 H1.
Qed.

(* stronger than inf unique *)
Lemma Typing_strenthening : forall G e A1 A2,
    []  ⊢ e ⇒ A1 ->
    G ⊢ e ⇒ A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2 G.
  inductions Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    inverts H0.
  - (* t_app *)
    forwards * : IHTy1_1 H2. subst.
    forwards*: arrTyp_unique H H4. inverts~ H0.
  - (* t_and *)
    forwards * : IHTy1_1 H2.
    substs.
    forwards * : IHTy1_2 H4.
    substs*.
  - (* t_and *)
    forwards * HT1: Typing_weakening G H4.
    forwards * HT2: Typing_weakening G H6.
    rewrite app_nil_r in HT1.
    rewrite app_nil_r in HT2.
    forwards * : IHTy1_1 HT1.
    substs.
    forwards * : IHTy1_2 HT2.
    substs*.
  - (* t_and *)
    forwards * HT1: IHTy1_1 H4.
    forwards * HT2: IHTy1_2 H6.
    substs*.
  - (* t_and *)
    forwards * : IHTy1_1 H6.
    forwards * : IHTy1_2 H8.
    substs*.
Qed.

Lemma inference_unique : forall G e A1 A2,
    Typing G e Inf A1 ->
    Typing G e Inf A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2.
  induction Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards*: binds_unique H0 H4.
  - (* t_app *)
    forwards * : IHTy1_1 H2. subst.
    forwards*: arrTyp_unique H H4. inverts H0.
    forwards * : IHTy1_1 H2.
  - (* t_and *)
    forwards * : IHTy1_1 H2.
    substs.
    forwards * : IHTy1_2 H4.
    substs*.
  - (* t_and *)
    forwards * HT1: Typing_weakening G H4.
    forwards * HT2: Typing_weakening G H6.
    rewrite app_nil_r in HT1.
    rewrite app_nil_r in HT2.
    forwards * : IHTy1_1 HT1.
    substs.
    forwards * : IHTy1_2 HT2.
    substs*.
  - (* t_and *)
    forwards* HT1: Typing_strenthening Ty1_1 H4.
    forwards* HT2: Typing_strenthening Ty1_2 H6.
    subst*.
  - (* t_and *)
    forwards *: IHTy1_1 H6.
    forwards *: IHTy1_2 H8.
    substs*.
Qed.

(* Infer Mode & Check Mode *)
Lemma Typing_inf_chk_sub: forall G e A B,
    Typing G e Inf A -> Typing G e Chk B -> sub A B.
Proof.
  intros G e A B H H0.
  lets (?&?&?): Typing_chk2inf H0.
  lets : inference_unique H H1.
  subst*.
Qed.


Require Import Coq.Lists.List.
Require Import coqutil.Datatypes.PrimitivePair.
Local Set Warnings "-notation-overridden".
Import pair.
Local Set Universe Polymorphism.

Module Import polymorphic_list.
  Inductive list {A : Type} : Type := nil | cons (_:A) (_:list).
  Arguments list : clear implicits.

  Section WithA. Local Set Default Proof Using "All".
    Context {A : Type}.
    Fixpoint length (l : list A) : nat :=
      match l with
      | nil => 0
      | cons _ l' => S (length l')
      end.
  End WithA.

  Section WithElement. Local Set Default Proof Using "All".
    Context {A} (x : A).
    Fixpoint repeat (x : A) (n : nat) {struct n} : list A :=
      match n with
      | 0 => nil
      | S k => cons x (repeat x k)
      end.
  End WithElement.
End polymorphic_list.

Fixpoint arrows (argts : list Type) : Type -> Type :=
  match argts with
  | nil => fun ret => ret
  | cons T argts' => fun ret => T -> arrows argts' ret
  end.

Fixpoint hlist@{i j k} (argts : list@{j} Type@{i}) : Type@{k} :=
  match argts with
  | nil => unit
  | cons T argts' => T * hlist argts'
  end.

Module hlist.
  Fixpoint apply {argts : list Type} : forall {P} (f : arrows argts P) (args : hlist argts), P :=
    match argts return forall {P} (f : arrows argts P) (args : hlist argts), P with
    | nil => fun P f _ => f
    | cons T argts' => fun P f '(x, args') => apply (f x) args'
    end.

  Fixpoint binds {argts : list Type} : forall {P} (f : hlist argts -> P), arrows argts P :=
    match argts return forall {P} (f : hlist argts -> P), arrows argts P with
    | nil => fun P f => f tt
    | cons T argts' => fun P f x => binds (fun xs' => f (x, xs'))
    end.

  Fixpoint foralls {argts : list Type} : forall (P : hlist argts -> Prop), Prop :=
    match argts with
    | nil => fun P => P tt
    | cons T argts' => fun P => forall x:T, foralls (fun xs' => P (x, xs'))
    end.

  Fixpoint existss {argts : list Type} : forall (P : hlist argts -> Prop), Prop :=
    match argts with
    | nil => fun P => P tt
    | cons T argts' => fun P => exists x:T, existss (fun xs' => P (x, xs'))
    end.

  Lemma foralls_forall {argts} {P} : @foralls argts P -> forall x, P x.
  Proof.
    revert P; induction argts as [|A argts']; intros P.
    { destruct x; eauto. }
    { cbn. intros H xs.
      refine (IHargts' (fun xs' => P (xs.(1), xs')) _ _); eauto. }
  Qed.

  Lemma existss_exists {argts} {P} : @existss argts P -> exists x, P x.
  Proof.
    revert P; induction argts as [|A argts']; intros P.
    { intro. exists tt. eauto. }
    { cbn. intros [x xs'].
      destruct (IHargts' (fun xs' => P (x, xs'))); eauto. }
  Qed.
End hlist.

Definition tuple A n := hlist (repeat A n).
Definition ufunc A n := arrows (repeat A n).
Module tuple.
  Notation apply := hlist.apply.
  Definition binds {A n} := hlist.existss (argts:=repeat A n).
  Definition foralls {A n} := hlist.foralls (argts:=repeat A n).
  Definition existss {A n} := hlist.existss (argts:=repeat A n).

  Import Datatypes.
  Section WithA. Local Set Default Proof Using "All".
    Context {A : Type}.
    Fixpoint to_list {n : nat} : tuple A n -> list A :=
      match n return tuple A n -> list A with
      | O => fun _ => nil
      | S n => fun '(pair.mk x xs') => cons x (to_list xs')
      end.

    Fixpoint of_list (xs : list A) : tuple A (length xs) :=
      match xs with
      | nil => tt
      | cons x xs => pair.mk x (of_list xs)
      end.

    Fixpoint option_all {sz : nat} : tuple (option A) sz -> option (tuple A sz) :=
      match sz with
      | O => fun _ => Some tt
      | S sz' => fun '(pair.mk ox xs) =>
                   match ox, option_all xs with
                   | Some x, Some ys => Some (pair.mk x ys)
                   | _ , _ => None
                   end
      end.

    Lemma to_list_of_list (xs : list A) :
      to_list (of_list xs) = xs.
    Proof. induction xs; cbn; congruence. Qed.

    Lemma length_to_list {n} xs : length (@to_list n xs) = n.
    Proof. revert xs; induction n; cbn; eauto. Qed.

    Lemma to_list_eq_rect a b xs pf
      : to_list (eq_rect a _ xs b pf) = to_list xs.
    Proof. destruct pf. cbn. trivial. Qed.

    Section WithF. Local Set Default Proof Using "All".
      Context {B: Type}.
      Context (f: A -> B).
      Fixpoint map{sz: nat}: tuple A sz -> tuple B sz :=
        match sz with
        | O => fun _ => tt
        | S sz' => fun '(pair.mk x xs) => pair.mk (f x) (map xs)
        end.
    End WithF.

    Section WithStep. Local Set Default Proof Using "All".
      Context (step : A -> A).
      Fixpoint unfoldn (n : nat) (start : A) : tuple A n :=
        match n with
        | O => tt
        | S n => pair.mk start (unfoldn n (step start))
        end.
    End WithStep.
  End WithA.
End tuple.