(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
From mathcomp Require Import all_ssreflect.
Require Import imonae_lib.
From HB Require Import structures.
Require Import ihierarchy imonad_lib.
From Equations Require Import Equations.

(******************************************************************************)
(*     Definitions and lemmas using failure and nondeterministic monads       *)
(*                                                                            *)
(*                arb == arbitrary nondeterministic choice between booleans   *)
(*              foldM                                                         *)
(*      unfoldM p f y == generates a list a from a seed y, if p y holds the   *)
(*                       generation stops,otherwise an element and a new seed *)
(*                       of generated using f                                 *)
(*              hyloM == [2, Sect. 5.1]                                       *)
(*    arbitrary def s == nondeterministic choice of an element in the list s, *)
(*                       def if the list is empty                             *)
(*             subs s == subsequence of a list                                *)
(*                       (ref: Sect. 3.1, gibbons2012utp)                     *)
(*         insert a s == insert a in the list s nondeterministically          *)
(*            iperm s == nondeterministic permutation of the list s, defined  *)
(*                       as a Fixpoint using insert [1, Sect. 3]              *)
(*           select s == nondeterministically splits the list s into a pair   *)
(*                       of one chosen element and the rest [3, Sect. 4.4]    *)
(*                       [2, Sect. 3.2]                                       *)
(*            uperm s == nondeterministically computes a permutation of s,    *)
(*                       defined using unfoldM and select [2, Sect. 3.2]      *)
(*           splits s == split a list nondeterministically                    *)
(*                       type: seq A -> M (seq A * seq A) with M : plusMonad  *)
(*         m1 `<=` m2 == m1 refines m2, i.e., every result of m1 is a         *)
(*                       possible result of m2                                *)
(*          f `<.=` g == refinement relation lifted to functions, i.e.,       *)
(*                       forall x, f x `<=` g x                               *)
(*                                                                            *)
(* ref:                                                                       *)
(* - [1] mu2019tr2                                                            *)
(* - [2] mu2019tr3                                                            *)
(* - [3] gibbons2011icfp                                                      *)
(* - [4] mu2020flops                                                          *)
(******************************************************************************)

Reserved Notation "m1 `<=` m2" (at level 70, no associativity).
Reserved Notation "f `<.=` g" (at level 70, no associativity).

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope monae_scope.

(* TODO: move *)
Lemma mem_rcons_cat (A : eqType) (b : seq A) h : h \in b ->
  exists b1 b2, b = rcons b1 h ++ b2.
Proof.
move=> hb; exists (take (index h b) b), (drop (index h b).+1 b).
rewrite -cats1 -catA -{1}(cat_take_drop (index h b) b); congr (_ ++ _) => /=.
by rewrite -{2}(nth_index h hb) -drop_nth // index_mem.
Qed.

Lemma bind_ext_guard {M : failMonad} (A : UU0) (b : bool) (m1 m2 : M A) :
  (b -> m1 = m2) -> guard b >> m1 = guard b >> m2.
Proof. by case: b => [->//|_]; rewrite guardF !bindfailf. Qed.

Definition arb {M : altMonad} : M bool := Ret true [~] Ret false.

Section monadalt_lemmas.
Variable (M : altMonad).

Lemma alt_fmapDr (A B : UU0) (f : A -> B) (m1 m2 : M A) :
  (M # f) (m1 [~] m2) = (M # f) m1 [~] (M # f) m2.
Proof. by rewrite 3!fmapE alt_bindDl. Qed.

End monadalt_lemmas.

Lemma fmap_fail {A B : UU0} (M : failMonad) (f : A -> B) :
  (M # f) fail = fail.
Proof. by rewrite fmapE bindfailf. Qed.

Lemma well_founded_size A : well_founded (fun x y : seq A => size x < size y).
Proof. by apply: (@Wf_nat.well_founded_lt_compat _ size) => ? ? /ltP. Qed.

Definition bassert_hylo {M : failMonad} (A B : UU0)
  (f : B -> M (A * B)%type) (p : pred B) (r : forall p f, B -> B -> bool) :=
  forall b, f b = bassert (fun z => r p f z.2 b) (f b).

Definition bassert_size {M : failMonad} (A B : UU0)
  (f : seq B -> M (A * seq B)%type) :=
  @bassert_hylo M _ _ f predT (fun _ _ x y => size x < size y).

Section foldM.
Variables (M : monad) (T R : UU0) (f : R -> T -> M R).
Fixpoint foldM z s : M _ := if s is x :: s' then f z x >>= (fun y => foldM y s') else (Ret z).
End foldM.

Section unfoldM.

Local Open Scope mprog.

Section unfoldM_monad.
Variables (M : monad) (A B : UU0).
Variable (r : B -> B -> bool).
Hypothesis wfr : well_founded r.
Variables (p : pred B) (f : B -> M (A * B)%type).

Definition unfoldM' (y : B) (g : forall y' : B, r y' y -> M (seq A)) : M (seq A) :=
  if p y then Ret [::] else f y >>=
    (fun xz => match Bool.bool_dec (r xz.2 y) true with
            | left H => fmap (cons xz.1) (g xz.2 H)
            | right H => Ret [::]
            end).
(* superfluous match to define the "recursive" call,
   to be removed by unfoldME under hypo. *)

Definition unfoldM := Fix wfr (fun _ => _ _) unfoldM'.

End unfoldM_monad.

Section unfoldM_failMonad.
Variables (M : failMonad) (A B' : UU0).
Let B := seq B'.
Notation unfoldM := (@unfoldM M A _ _ (@well_founded_size B')).
Variables (p : pred B) (f : B -> M (A * B)%type).

Hypothesis decr_size : bassert_size f.

Lemma unfoldME y : unfoldM p f y =
  if p y then Ret [::]
  else f y >>= (fun xz => fmap (cons xz.1) (unfoldM p f xz.2)).
Proof.
rewrite /unfoldM Init.Wf.Fix_eq; last first.
  move => b g g' H; rewrite /unfoldM'; case: ifPn => // pb.
  bind_ext => -[a' b'] /=.
  destruct Bool.bool_dec => //; by rewrite H.
rewrite /unfoldM'; case: ifPn => // py.
rewrite decr_size /bassert 2!bindA; bind_ext => -[a' b'].
case: assertPn => b'y; last by rewrite 2!bindfailf.
by rewrite 2!bindretf /= b'y.
Qed.

End unfoldM_failMonad.

End unfoldM.
Arguments unfoldM : simpl never.

Section hyloM.
Variables (M : failMonad) (A B C : UU0).
Variables (op : A -> M C -> M C) (e : C) (p : pred B) (f : B -> M (A * B)%type).
Variable seed : forall (p : pred B) (f : B -> M (A * B)%type), B -> B -> bool.

Definition hyloM' (y : B) (g : forall y', seed p f y' y -> M C) : M C :=
  if p y then Ret e else f y >>=
    (fun xz => match Bool.bool_dec (seed p f xz.2 y) true with
            | left H => op xz.1 (g xz.2 H)
            | right H => Ret e
            end).

Hypothesis well_founded_seed : well_founded (seed p f).

Definition hyloM := Fix well_founded_seed (fun _ => M _) hyloM'.

Hypothesis Hdecr_seed : bassert_hylo f p seed.

Lemma hyloME y : hyloM y = if p y then
                             Ret e
                           else
                             f y >>= (fun xz => op xz.1 (hyloM xz.2)).
Proof.
rewrite /hyloM Init.Wf.Fix_eq; last first.
  move => b g g' K; rewrite /hyloM'; case: ifPn => // pb.
  bind_ext => -[a' b'] /=.
  destruct Bool.bool_dec => //.
  by rewrite K.
rewrite {1}/hyloM'; case: ifPn => // py.
rewrite Hdecr_seed /bassert !bindA.
bind_ext => -[b' a'].
case: assertPn => Hseed; last by rewrite 2!bindfailf.
by rewrite 2!bindretf Hseed.
Qed.

End hyloM.
Arguments hyloM {M} {A} {B} {C} _ _ _ _ _.

Section arbitrary.

Variables (M : altMonad) (A : UU0) (def : A).

Definition arbitrary : seq A -> M A :=
  foldr1 (Ret def) (fun x y => x [~] y) \o map Ret.

End arbitrary.
Arguments arbitrary {M} {A}.

Lemma arbitrary1 (N : altMonad) (T : UU0) (def : T) h :
  arbitrary def [:: h] = Ret h :> N T.
Proof. by []. Qed.

Section arbitrary_lemmas.
Variables (M : altCIMonad).

Lemma arbitrary2 (T : UU0) (def : T) h t :
  arbitrary def [:: h; t] = Ret h [~] Ret t :> M _.
Proof. by rewrite /arbitrary /= altC. Qed.

Lemma arbitrary_cons (T : UU0) (def : T) h t : 0 < size t ->
  arbitrary def (h :: t) = Ret h [~] arbitrary def t :> M _.
Proof.
move: def h; elim: t => // a [//|b [|c t]] ih def h _.
- by rewrite arbitrary2.
- by rewrite /arbitrary /= altA altC (altC (Ret b)).
- move: (ih a h erefl); rewrite /arbitrary /= => ->.
  move: (ih h a erefl); rewrite /arbitrary /= => ->.
  by rewrite altCA.
Qed.

Lemma arbitrary_naturality (T U : UU0) (a : T) (b : U) (f : T -> U) :
  forall x, 0 < size x -> (M # f \o arbitrary a) x = (arbitrary b \o map f) x.
Proof.
elim=> // x [_ _ | x' xs /(_ isT)].
  by rewrite [in LHS]compE fmapE bindretf.
rewrite [in X in X -> _]/= fmapE => ih _.
rewrite [in RHS]compE [in RHS]/= [in RHS](arbitrary_cons b) // [in LHS]compE.
by rewrite [in LHS]arbitrary_cons // fmapE /= alt_bindDl bindretf /= ih.
Qed.

Lemma mpair_arbitrary_base_case (T : UU0) a x (y : seq T) :
  (0 < size y)%nat ->
  arbitrary (a, a) (cp [:: x] y) = mpair (arbitrary a [:: x], arbitrary a y) :> M _.
Proof.
move=> y0; rewrite cp1.
transitivity (arbitrary a y >>= (fun y' => Ret (x, y')) : M _).
  by rewrite -(compE (arbitrary _)) -(arbitrary_naturality a) // compE fmapE.
transitivity (do z <- Ret x; do y' <- arbitrary a y; Ret (z, y') : M _)%Do.
  by rewrite bindretf.
by [].
Qed.

Lemma arbitrary_cat (T : UU0) (a : T) s t :
  let m := size s in let n := size t in
  0 < m -> 0 < n ->
  arbitrary a (s ++ t) = arbitrary a s [~] arbitrary a t :> M _.
Proof.
elim: s t => [//|s1 s2 IH].
elim/last_ind => // t1 t2 _ m n m0 n0 //.
rewrite cat_cons [in LHS]arbitrary_cons; last first.
  by rewrite size_cat size_rcons addnS.
destruct s2 as [|s2 s3] => //.
rewrite IH // altA; congr (_ [~] _).
by rewrite [in RHS]arbitrary_cons.
Qed.

Lemma mpair_arbitrary (T : UU0) a (x y : seq T) :
  0 < size x -> 0 < size y ->
  mpair (arbitrary a x, arbitrary a y) = arbitrary (a, a) (cp x y) :> M (T * T)%type.
Proof.
elim: x y => // x; case=> [_ y _ size_y|x' xs IH y _ size_y]; apply/esym.
  exact/mpair_arbitrary_base_case.
set xxs := x' :: xs.
rewrite /cp -cat1s allpairs_cat -/(cp _ _) cp1 /= arbitrary_cat; last 2 first.
  by rewrite size_map.
  by rewrite size_cat size_map addn_gt0 size_y.
pose n := size y.
pose l := size (cp xxs y).
rewrite -IH //.
rewrite -/xxs.
move: (mpair_arbitrary_base_case a x size_y).
rewrite {1}/cp [in X in arbitrary _ X]/= cats0 => ->.
rewrite -alt_bindDl.
by rewrite -arbitrary_cat.
Qed.

Lemma arbitrary_inde (T : UU0) a (s : seq T) {U} (m : M U) :
  0 < size s -> arbitrary a s >> m = m.
Proof.
elim: s a m => // h [_ a m _|h' t ih a m _].
  by rewrite arbitrary1 bindretf.
by rewrite arbitrary_cons // alt_bindDl ih // bindretf altmm.
Qed.

Lemma arbitrary_flatten (A : UU0) def (s : seq A) (f : A -> A) : (0 < size s)%nat ->
  (do x <- arbitrary def s; Ret (f x))%Do =
  arbitrary def (flatten [seq [:: f y] | y <- s]) :> M _.
Proof.
elim: s f => // a [_ f _ /=|h t ih f _].
  by rewrite /arbitrary /= bindretf.
rewrite [h :: t]lock /= -lock [in RHS]arbitrary_cons// -ih//.
by rewrite arbitrary_cons// alt_bindDl bindretf.
Qed.

Lemma arbitrary_flatten2 (A : UU0) def (s : seq A) (f g : A -> A) : (0 < size s)%nat ->
  (do x <- arbitrary def s; Ret (f x) [~] Ret (g x))%Do =
  arbitrary def (flatten [seq [:: f y; g y] | y <- s]) :> M _.
Proof.
elim: s def f g => //.
move=> h [|t1 t2] ih def f g _.
  by rewrite /= arbitrary1 bindretf arbitrary_cons //.
rewrite [t1 :: t2]lock /= -lock [in RHS]arbitrary_cons//.
rewrite [in RHS]arbitrary_cons// -ih// arbitrary_cons//.
by rewrite alt_bindDl bindretf altA.
Qed.

End arbitrary_lemmas.
Arguments arbitrary_naturality {M T U}.

Section subsequences_of_a_list.
Local Open Scope mprog.

Variables (M : altMonad) (A : UU0).

Fixpoint subs (s : seq A) : M (seq A) :=
  if s isn't h :: t then Ret [::] else
  let t' := subs t in
  fmap (cons h) t' [~] t'.

(*Fixpoint SUBS (s : list A) : MonadAlt.sort M (list A) :=
  if s isn't h :: t then
      @Natural.cpnt ssrfun_idfun__canonical__ihierarchy_Functor
        (@Functor.Pack (Monad.sort (ihierarchy_MonadAlt__to__ihierarchy_Monad M))
           (@Functor.Class (Monad.sort (ihierarchy_MonadAlt__to__ihierarchy_Monad M))
              (@Monad.ihierarchy_isFunctor_mixin (Monad.sort (ihierarchy_MonadAlt__to__ihierarchy_Monad M))
                 (Monad.class (ihierarchy_MonadAlt__to__ihierarchy_Monad M))))) (@ret (ihierarchy_MonadAlt__to__ihierarchy_Monad M))
        (list A) (@nil A)
  else
      let t' : MonadAlt.sort M (list A) := SUBS t in
      @alt M (list A) (@actm (ihierarchy_MonadAlt__to__ihierarchy_Functor M) (list A) (list A) (@cons A h) t') t'.
Goal subs = SUBS. by []. Abort.*)

Lemma subs_cons x (xs : seq A) :
  subs (x :: xs) = let t' := subs xs in fmap (cons x) t' [~] t'.
Proof. by []. Qed.

Lemma subs_cat (xs ys : seq A) :
  (subs (xs ++ ys) = do us <- subs xs; do vs <- subs ys; Ret (us ++ vs))%Do.
Proof.
elim: xs ys => [ys |x xs ih ys].
  by rewrite cat0s /= bindretf bindmret.
rewrite {1}[in RHS]/subs fmapE -/(subs _) alt_bindDl bindA.
Open (X in subs xs >>= X).
  rewrite bindretf.
  under eq_bind do rewrite cat_cons.
  over.
rewrite [X in _ = X [~] _](_ : _ = fmap (cons x) (do x0 <- subs xs; do x1 <- subs ys; Ret (x0 ++ x1)))%Do; last first.
  rewrite fmapE bindA.
  bind_ext => x0.
  rewrite bindA.
  by under [in RHS]eq_bind do rewrite bindretf.
by rewrite -ih cat_cons subs_cons.
Qed.

End subsequences_of_a_list.

Section insert.
Context {M : altMonad} {A : UU0}.
Local Open Scope mprog.

Fixpoint insert (a : A) (s : seq A) : M (seq A) :=
  if s isn't h :: t then Ret [:: a] else
  Ret (a :: h :: t) [~] fmap (cons h) (insert a t).

Lemma insertE (a : A) s :
  insert a s = if s isn't h :: t then Ret [:: a] else
  Ret (a :: h :: t) [~] fmap (cons h) (insert a t).
Proof. by case: s. Qed.

End insert.
Arguments insert : simpl never.

Section insert_altMonad.
Variable M : altMonad.
Local Open Scope mprog.

(* see also netys2017 *)
Lemma insert_map (A B : UU0) (f : A -> B) (a : A) :
  insert (f a) \o map f = map f (o) insert a :> (_ -> M _).
Proof.
apply funext; elim => [|y xs IH].
  by rewrite fcompE insertE -(compE (fmap (map f))) (natural ret) compE insertE.
apply/esym.
rewrite fcompE insertE alt_fmapDr.
(* first branch *)
rewrite -(compE (fmap (map f))) (natural ret) FIdE [in X in X [~] _ ]/=.
(* second branch *)
rewrite -fmap_oE (_ : map f \o cons y = cons (f y) \o map f) //.
by rewrite fmap_oE -(fcompE (map f)) -IH [RHS]/= insertE.
Qed.

Hypothesis Mmm : forall A, idempotent (@alt _ A : M A -> M A -> M A).

Variables (A : UU0) (p : pred A).

Lemma filter_insertN a : ~~ p a ->
  forall s, (filter p (o) insert a) s = Ret (filter p s) :> M _.
Proof.
move=> pa; elim => [|h t IH].
  by rewrite fcompE insertE -(compE (fmap _)) (natural ret) FIdE /= (negbTE pa).
rewrite fcompE insertE alt_fmapDr.
rewrite -(compE (fmap _)) (natural ret) FIdE [in X in X [~] _]/= (negbTE pa).
case: ifPn => ph.
- rewrite -fmap_oE (_ : filter p \o cons h = cons h \o filter p); last first.
    by apply funext => x /=; rewrite ph.
  rewrite fmap_oE.
  move: (IH); rewrite fcompE => ->.
  by rewrite fmapE /= ph bindretf /= Mmm.
- rewrite -fmap_oE (_ : filter p \o cons h = filter p); last first.
    by apply funext => x /=; rewrite (negbTE ph).
  by move: (IH); rewrite fcompE => -> /=; rewrite (negbTE ph) Mmm.
Qed.

Lemma filter_insertT a : p a ->
  filter p (o) insert a = insert a \o filter p :> (_ -> M _).
Proof.
move=> pa; apply funext; elim => [|h t IH].
  by rewrite fcompE !insertE fmapE bindretf /= pa.
rewrite fcompE [in RHS]/=; case: ifPn => ph.
- rewrite [in RHS]insertE.
  move: (IH); rewrite [in X in X -> _]/= => <-.
  rewrite [in LHS]insertE alt_fmapDr; congr (_ [~] _).
    by rewrite fmapE bindretf /= pa ph.
  rewrite !fmapE /= fcompE bind_fmap bindA.
  under [LHS]eq_bind do rewrite bindretf.
  by rewrite /= ph.
- rewrite [in LHS]insertE alt_fmapDr.
  rewrite -[in X in _ [~] X = _]fmap_oE.
  rewrite (_ : (filter p \o cons h) = filter p); last first.
    by apply funext => x /=; rewrite (negbTE ph).
  move: (IH); rewrite fcompE => ->.
  rewrite fmapE bindretf /= pa (negbTE ph) [in RHS]insertE; case: (filter _ _) => [|h' t'].
    by rewrite insertE Mmm.
  by rewrite !insertE altA Mmm.
Qed.

End insert_altMonad.

(* mu2019tr2, Sect. 3, see also netsys2017 *)
Section insert_altCIMonad.
Variables (M : altCIMonad) (A : UU0) (a : A).
Local Open Scope mprog.

Lemma insert_rcons a' s :
  insert a (rcons s a') =
    Ret (s ++ [:: a'; a]) [~] fmap (rcons^~ a') (insert a s) :> M _.
Proof.
elim: s a' => [a'|s1 s2 IH a'].
  rewrite cat0s fmapE bindretf insertE altC; congr (_ [~] _).
  by rewrite insertE fmapE bindretf.
rewrite [in LHS]/= insertE IH.
rewrite alt_fmapDr [in X in _ [~] X = _]fmapE bindretf.
rewrite alt_fmapDr [in X in _ = _ [~] X]fmapE bindretf.
by rewrite -!fmap_oE altCA.
Qed.

Lemma rev_insert : rev (o) insert a = insert a \o rev :> (_ -> M _).
Proof.
apply funext; elim => [|h t ih].
  by rewrite fcompE insertE fmapE bindretf.
rewrite fcompE insertE compE alt_fmapDr fmapE bindretf compE [in RHS]rev_cons.
rewrite insert_rcons rev_cons -cats1 rev_cons -cats1 -catA; congr (_ [~] _).
move: ih; rewrite fcompE [X in X -> _]/= => <-.
rewrite -!fmap_oE. congr (fmap _ (insert a t)).
by apply funext => s; rewrite /= -rev_cons.
Qed.

End insert_altCIMonad.

Lemma test_canonical (M : nondetMonad) A (a : M A) (b : A -> M A) :
  a [~] (fail >>= b) = a [~] fail.
Proof.
Set Printing All.
Unset Printing All.
by rewrite bindfailf.
Abort.

Section insert_plusMonad.
Variable M : plusMonad.

Lemma insertC (A : UU0) a b (s : seq A) :
  (do x <- insert b s; insert a x = do x <- insert a s; insert b x :> M _)%Do.
Proof.
have [n ns] := ubnP (size s); elim: n s ns a b => // n ih s ns a b.
case: s ns => [|h t].
  by rewrite !insertE !bindretf !insertE altC !fmapE !bindretf.
rewrite ltnS /= => ns.
rewrite (insertE _ (h :: t)) alt_bindDl bindretf.
rewrite [in LHS](insertE _ [:: b, h & t]) [in LHS](insertE _ (h :: t)).
rewrite [in RHS](insertE _ (h :: t)) [in RHS]alt_bindDl bindretf.
rewrite 2![in RHS]insertE.
rewrite [in LHS]alt_fmapDr ![in LHS]altA [in LHS](altC (Ret [:: a, b, h & t])).
rewrite -!altA; congr (_ [~] _); first by rewrite fmapE bindretf.
rewrite alt_fmapDr -!altA; congr (_ [~] _); first by rewrite fmapE bindretf.
rewrite [in LHS]altC bind_fmap /= [in LHS]/comp /=.
under eq_bind do rewrite insertE.
rewrite alt_bindDr.
under [in X in (_ [~] X) [~] _]eq_bind do rewrite fmapE.
rewrite -bindA [in LHS]ih // [in RHS]altC bind_fmap /= [in RHS]/comp /=.
under [in RHS]eq_bind do rewrite insertE.
rewrite alt_bindDr [in RHS]altC -!altA; congr (_ [~] _).
  rewrite !fmapE !bindA.
  by under [in RHS]eq_bind do rewrite !bindretf.
rewrite [in RHS]altC; congr (_ [~] _); last first.
  rewrite !fmapE !bindA.
  by under eq_bind do rewrite bindretf.
rewrite bindA.
by under [in RHS]eq_bind do rewrite fmapE.
Qed.

Lemma insert_cat (A : UU0) h (a b : seq A) u :
  insert h (a ++ u :: b) = (do x <- insert h a; Ret (x ++ u :: b))%Do [~]
                          (do x <- insert h b; Ret (a ++ u :: x))%Do :> M _.
Proof.
elim: a h u b => [h u b|a1 a2 ih h u b].
  by rewrite /= (insertE h nil) bindretf insertE fmapE.
rewrite cat_cons [in LHS]insertE [u :: b]lock /= -lock [in LHS]ih.
rewrite [in RHS]insertE [in RHS]alt_bindDl bindretf -altA; congr (_ [~] _).
rewrite [in RHS]bind_fmap [in LHS]fmapE [in LHS]alt_bindDl !bindA.
by congr (_ [~] _); under eq_bind do rewrite bindretf.
Qed.

End insert_plusMonad.

Section insert_nondetMonad.
Context {M : nondetMonad} {A : UU0}.
Implicit Types s : seq A.

Lemma insert_Ret a s : exists m, insert a s = Ret (a :: s) [~] m :> M _.
Proof.
elim: s => [|h t [m ih]] /=; last by eexists; rewrite insertE; reflexivity.
by rewrite insertE; exists fail; rewrite altmfail.
Qed.

End insert_nondetMonad.

Fixpoint iperm {M : altMonad} {A : UU0} (s : seq A) : M (seq A) :=
  if s isn't h :: t then Ret [::] else iperm t >>= insert h.

Section iperm_altMonad.
Context {M : altMonad}.
Local Open Scope mprog.

(* lemma 3.3 in mu2019tr2 *)
Lemma iperm_o_map (A B : UU0) (f : A -> B) :
  iperm \o map f = map f (o) iperm :> (_ -> M _).
Proof.
apply funext; elim => [/=|x xs IH].
  by rewrite fcompE [iperm _]/= -[in RHS]compE (natural ret).
by rewrite fcompE [in iperm _]/= fmap_bind -insert_map -bind_fmap -fcompE -IH.
Qed.

Hypothesis Mmm : forall A, idempotent (@alt _ A : M A -> M A -> M A).

Variables (A : UU0) (p : pred A).

(* netys2017 *)
Lemma iperm_filter : iperm \o filter p = filter p (o) iperm :> (_ -> M _).
Proof.
apply funext; elim => [|h t /= IH].
  by rewrite fcompE fmapE bindretf.
case: ifPn => ph.
  rewrite [in LHS]/= IH [in LHS]fcomp_def compE [in LHS]bind_fmap.
  rewrite [in RHS]fcomp_def compE -/(fmap _ _) [in RHS]fmap_bind; bind_ext => s.
  by rewrite filter_insertT.
rewrite fcompE fmap_bind IH fcompE fmapE; bind_ext => s.
by rewrite filter_insertN.
Qed.

End iperm_altMonad.

Section iperm_nondetMonad.
Context {M : nondetMonad} {A : UU0}.
Implicit Types s : seq A.

Lemma iperm_is_alt_ret s : exists m, iperm s = Ret s [~] m :> M _.
Proof.
elim: s => [|h t [m ih] /=]; first by exists fail; rewrite altmfail.
case: (@insert_Ret M A h t) => n Hn.
by eexists; rewrite ih alt_bindDl bindretf Hn -altA.
Qed.

End iperm_nondetMonad.

Section iperm_plusMonad.
Context {M : plusMonad}.

Lemma iperm_insert {A : UU0} a b (s t : seq A) :
  (do x <- iperm (b :: s ++ t); insert a x =
   do x <- iperm (rcons s a ++ t); insert b x :> M _)%Do.
Proof.
elim: s => [/=|h tl ih] in a b t *.
  rewrite !bindA.
  by under eq_bind do rewrite insertC.
rewrite [h :: tl]lock /= -lock ih /= !bindA.
suff : (do x <- iperm (rcons tl b ++ t); do x0 <- insert a x; insert h x0 =
    do x <- iperm (rcons tl a ++ t); do x0 <- insert b x; insert h x0 :> M _)%Do.
  under eq_bind do rewrite insertC.
  move=> ->.
  by under eq_bind do rewrite insertC.
rewrite -bindA -ih /= -bindA -[in RHS]ih /= !bindA; bind_ext => a'.
by rewrite -bindA insertC bindA.
Qed.

End iperm_plusMonad.

Section select.
Variables (M : nondetMonad) (A : UU0).
Implicit Types s : seq A.

Fixpoint select s : M (A * seq A)%type :=
  if s isn't h :: t then fail else
  (Ret (h, t) [~] select t >>= (fun x => Ret (x.1, h :: x.2))).
(* NB: see .. for the theory of select *)

End select.
Arguments select {M} {A}.

Section uperm.
Variables (A : UU0) (M : nondetMonad).

Definition uperm : seq A -> M (seq A) :=
  unfoldM (@well_founded_size _) (@nilp _) select.
(* NB: see .. for the theory of mu_perm *)

End uperm.
Arguments uperm {A} {M}.

Section splits.
Context {M : altMonad} {A : UU0}.
Implicit Types s : seq A.

Fixpoint splits s : M (seq A * seq A)%type :=
  if s isn't x :: xs then Ret ([::], [::]) else
    splits xs >>= (fun yz => Ret (x :: yz.1, yz.2) [~] Ret (yz.1, x :: yz.2)).

End splits.

(* TODO: move this example *)
Section fastproduct.

Definition product := foldr muln 1.

Lemma product0 s : O \in s -> product s = O.
Proof.
elim: s => //= h t ih; rewrite inE => /orP[/eqP <-|/ih ->];
  by rewrite ?muln0 ?mul0n.
Qed.

Section work.
Variable M : failMonad.
Local Open Scope mprog.

Definition work s : M nat :=
  if O \in s then fail else Ret (product s).

Let Work s := if O \in s then @fail M nat
              else Ret (product s).

(* work refined to eliminate multiple traversals *)
Lemma workE :
  let next := fun n (mx : M _) => if n == 0 then fail else fmap (muln n) mx in
  work = foldr next (Ret 1).
Proof.
apply foldr_universal => // h t; case: ifPn => [/eqP -> //| h0].
by rewrite /work inE eq_sym (negbTE h0) [_ || _]/= fmap_if fmap_fail.
Qed.

End work.
Arguments work {M}.

Variable M : exceptMonad.

Definition fastprod s : M _ := catch (work s) (Ret O).

Let Fastprod (s : seq nat) := @catch M nat (work s) (Ret O).

(* fastprod is pure, never throwing an unhandled exception *)
Lemma fastprodE s : fastprod s = Ret (product s).
Proof.
rewrite /fastprod /work fun_if if_arg catchfailm.
by rewrite catchret; case: ifPn => // /product0 <-.
Qed.

End fastproduct.

Definition addM (M : monad) (a b : M nat) : M nat :=
  a >>= (fun x => b >>= (fun y => Ret (x + y))).
Notation "a +m b" := (addM a b) (at level 50, format "a  +m  b").

Definition mulM (M : monad) (a b : M nat) : M nat :=
  a >>= (fun x => b >>= (fun y => Ret (x * y))).
Notation "a *m b" := (mulM a b) (at level 50, format "a  *m  b").

(* TODO: examples below are about control monads and should maybe be moved to a
new file; reference: Wadler, P. Monads and composable continuations. LISP and
Symbolic Computation 7, 39–55 (1994) *)

Section continuation_example.
Variable M : contMonad.

Let wadler94_sect31 : Ret 1 +m callcc (fun f => Ret 10 +m f 100) = Ret (1 + 100) :> M _.
Proof.
rewrite {1}/addM bindretf.
rewrite (_ : callcc _ = Ret 100) ?bindretf //.
transitivity (callcc (fun _ : nat -> M nat => Ret 100)); last by rewrite callcc1.
transitivity (callcc (fun f : nat -> M nat => Ret 10 >>= (fun a => f 100))); first by rewrite callcc2.
rewrite callcc3 //; congr callcc.
by apply funext => g; rewrite bindretf.
Qed.

End continuation_example.

Section shiftreset_examples.
Variable (M : shiftresetMonad nat).

Let wadler94_sect32_1 :
  Ret 1 +m (reset (Ret 10 +m (shift (fun f : _ -> M nat => f 100 >>= f) : M _)) : M _) =
  Ret (1 + (10 + (10 + 100))).
Proof.
rewrite /addM.
rewrite bindretf.
transitivity ((Ret (10 + (10 + 100))) >>= (fun y => Ret (1 + y)) : M _); last first.
  by rewrite bindretf.
congr (bind _ _).
rewrite shiftreset3.
rewrite (_ : do x <- Ret 10; _ = do y <- shift (@^~ 100) : M _; Ret (10 + (10 + y)))%Do; last first.
  by rewrite bindretf.
by rewrite shiftreset4.
Qed.

Let wadler94_sect32_2 :
  Ret 1 +m (reset (Ret 10 +m (shift (fun f : _ -> M nat => Ret 100 : M _) : M _)) : M _) =
  Ret (1 + 100).
Proof.
rewrite /addM.
rewrite bindretf.
transitivity (Ret 100 >>= (fun y => Ret (1 + y)) : M _); last first.
  by rewrite bindretf.
congr (bind _ _). (* TODO : bind_ext casse *)
rewrite (shiftreset2 _ _).
by rewrite bindretf.
Qed.

End shiftreset_examples.

Definition refin (M : altMonad) A (m1 m2 : M A) : Prop := m1 [~] m2 = m2.
Notation "m1 `<=` m2" := (refin m1 m2).

Lemma refin_bindr (M : altMonad) A B (m1 m2 : M A) (f : A -> M B) :
  (m1 `<=` m2) -> (m1 >>= f `<=` m2 >>= f).
Proof. by move=> m12; rewrite /refin -alt_bindDl m12. Qed.

Lemma refin_if (M : altMonad) A (m1 m2 m1' m2' : M A) (b : bool) :
  (b -> m1 `<=` m1') -> (~~ b -> m2 `<=` m2') ->
  (if b then m1 else m2) `<=` (if b then m1' else m2').
Proof. by case: b => [+ _|_]; exact. Qed.

Import Order.TTheory.
Local Open Scope order_scope.

Section refin_lemmas_altCIMonad.
Variable M : altCIMonad.
Implicit Types A : UU0.

Lemma refin_refl A (a : M A) : a `<=` a.
Proof. by rewrite /refin altmm. Qed.

Lemma eq_refin A (a b : M A) : a = b -> a `<=` b.
Proof. by move=> ->; exact: refin_refl. Qed.

Lemma refin_trans A (b a c : M A) : a `<=` b -> b `<=` c -> a `<=` c.
Proof. by rewrite /refin => h1 <-; rewrite altA h1. Qed.

Lemma refin_antisym A (a b : M A) : a `<=` b -> b `<=` a -> a = b.
Proof. by rewrite /refin => h1 <-; rewrite altC. Qed.

Lemma refin_alt A (m1 m1' m2 m2' : M A) :
  m1 `<=` m1' -> m2 `<=` m2' -> m1 [~] m2 `<=` m1' [~] m2'.
Proof. by move=> h1 h2; rewrite /refin altACA h1 h2. Qed.

Lemma refinR A (a b : M A) : a `<=` a [~] b.
Proof. by rewrite /refin altA altmm. Qed.

End refin_lemmas_altCIMonad.

Definition lrefin {M : altMonad} A B (f g : A -> M B) := forall x, f x `<=`g x.
Notation "f `<.=` g" := (lrefin f g).

Section lrefin_lemmas_altCIMonad.
Variable M : altCIMonad.

Lemma lrefin_refl A B (a : A -> M B) : a `<.=` a.
Proof. by move => ?; exact: refin_refl. Qed.

Lemma lrefin_trans A B (b a c : A -> M B) : a `<.=` b -> b `<.=` c -> a `<.=` c.
Proof. by move => ? ? ?; exact: refin_trans. Qed.

Lemma lrefin_antisym A B (a b : A -> M B) : a `<.=` b -> b `<.=` a -> a = b.
Proof. move => ? ?; apply funext => ?; exact: refin_antisym. Qed.
End lrefin_lemmas_altCIMonad.

Lemma refin_bindl (M : prePlusMonad) A B (m : M A) (f g : A -> M B) :
  (f `<.=` g) -> (m >>= f `<=` m >>= g).
Proof. by move=> fg; rewrite /refin -alt_bindDr; bind_ext => a; exact: fg. Qed.

Lemma refin_bind (M : plusMonad) A B {m n : M A} {f g : A -> M B} :
  m `<=` n -> f `<.=` g -> (m >>= f) `<=` (n >>= g).
Proof.
by move=> mn /refin_bindl ?; exact: (refin_trans _ (refin_bindr _ mn)).
Qed.

Lemma refin_liftM2 (M : plusMonad) (A B C : UU0) {f : A -> B -> C}
    {m1 n1 : M A} {m2 n2 : M B} :
  m1 `<=` n1 -> m2 `<=` n2 -> liftM2 f m1 m2 `<=` liftM2 f n1 n2.
Proof.
move=> mn1 mn2; rewrite /liftM2.
by apply: (refin_bind mn1 _) => a; exact: refin_bindr.
Qed.

Lemma refin_guard_le (M : plusMonad) (d : unit) (T : orderType d) (x y : T) :
  (guard (~~ (y <= x)%O) : M _) `<=` guard (x <= y)%O.
Proof.
rewrite -ltNge le_eqVlt.
case: guardPn => H.
rewrite orbT guardT; exact: refin_refl.
by rewrite orbF /refin altfailm.
Qed.

Lemma refin_if_guard (M : plusMonad) A (p : bool) (m1 m2 : M A) :
  (if p then m1 else m2) `<=` (guard p >> m1) [~] (guard (~~ p) >> m2).
Proof.
rewrite /refin; case: ifPn => /= [pT|pF]; rewrite !(guardT,guardF).
by rewrite bindskipf bindfailf altA altmm.
by rewrite bindfailf bindskipf altCA altmm.
Qed.

(* NB: worth explaining *)
Lemma refin_bind_guard {M : plusMonad} A (b : bool) (m1 m2 : M A) :
  (b -> m2 `<=` m1) -> guard b >> m2 `<=` guard b >> m1.
Proof.
case: b => [h|_]; first by apply: refin_bindl => -[]; exact: h.
by rewrite guardF !bindfailf; exact: refin_refl.
Qed.

Lemma refin_ret_insert (M : altCIMonad) (A : UU0) h (t : seq A) :
  Ret (h :: t) `<=` (insert h t : M _).
Proof.
elim: t h => [h|t1 t2 ih h]; first by rewrite insertE; exact: refin_refl.
by rewrite insertE; exact: refinR.
Qed.

Lemma refin_ret_iperm (M : plusMonad) (A : UU0) (s : seq A) :
  (Ret s : M _) `<=` iperm s.
Proof.
by case: (@iperm_is_alt_ret M _ s) => m ->; rewrite /refin altA altmm.
Qed.


Require Import List.
Require Import Arith.
Require Import Program.

Require Import Axioms.
Require Import JMUtils.
Require Import TypeSyntax.
Require Import Semantics.
Require Import Shifting.

Set Implicit Arguments.

Definition subst_lookup_var_eq : forall i g1 g2 ty1 (l : i < g1 + 1 + g2),
  forall (e1 : ty_environment g1) (e2 : ty_environment g2),
     ty_sem (app e1 e2) (subst_var g2 g1 (var l) (refl_equal (g1 + 1 + g2)) ty1) =
     lookup_var (var l) (app (app e1 (ty_sem (app e1 e2) ty1;: ty_nil)) e2).
intros.
unfold ty_sem in *.
simpl in *. unfold eq_rec_r in *. simpl.
revert ty1.
destruct (lt_eq_lt_dec i g1) as [[X|X]|X]; simpl.
 (* i < g1 *)
 generalize (app e1 e2) at 2 as e3.
 generalize (lt_plus_trans i g1 g2 X).
 intros. set (Y:=lookup l0 (app e1 e2)). revert ty1 e3. generalize (g1 + g2) as g3.
 unfold Y. clear Y.
 revert g1 g2 l e1 e2 X l0. induction i; intros.
  (* i = 0 *)
  destruct e1.
   (* e1 = ty_nil *)
   elimtype False. inversion X.
   (* e1 = ty_cons *)
   simpl in *. reflexivity.
  (* i > 0 *)
  destruct e1.
   (* e1 = ty_nil *)
   elimtype False. inversion X.
   (* e1 = ty_cons ... *)
   simpl. fold plus. eapply IHi.
    apply lt_S_n. assumption.
 (* i = g1 *)
 generalize (app e1 e2) as e3.
 generalize (g1 + g2) as g3.
 intros.
 revert g1 g2 l e1 e2 X. induction i; intros.
  (* i = 0 *)
  destruct e1.
   (* e1 = ty_nil *)
   simpl in *. reflexivity.
   (* e1 = ty_cons *)
   elimtype False. inversion X.
  (* i > 0 *)
  destruct e1.
   (* e1 = ty_nil *)
   elimtype False. inversion X.
   (* e1 = ty_cons *)
   simpl in *. fold plus. apply IHi.
    inversion X. reflexivity.
 (* g1 < i *)
 destruct (O_or_S i) as [[i' i'_Si]|i_0].
  (* i = S i' *)
  simpl in *.
  intros.  match goal with [|-lookup ?X _ = _] => generalize X end. intros.
  set (Y:=lookup l0 (app e1 e2)).
  revert ty1. generalize (app e1 e2) as e3. generalize (g1 + g2) as g3.
  intros. unfold Y. clear Y.
  revert g1 g2 l e1 e2 X l0. subst i. induction i'; intros.
   (* i' = 0 *)
   destruct e1.
    (* e1 = ty_nil *)
    simpl in *. apply f_equal. apply proof_irrelevance.
    (* e1 = ty_cons *)
    elimtype False. inversion X. inversion H0.
   (* i' > 0 *)
   destruct e1.
    (* e1 = ty_nil *)
    simpl in *. apply f_equal. apply proof_irrelevance.
    (* e1 = ty_cons *)
    simpl app. simpl lookup. fold plus.
    eapply IHi' with (l:=lt_S_n (S i') (i + 1 + g2) l).
     apply lt_S_n. assumption.
  (* i = 0 *)
  elimtype False. subst i. inversion X.
Save.

Lemma subst_lookup_var_rel : forall i g1 g2 ty1 (l:i < g1 + 1 + g2)
  (e11 e12 : ty_environment g1) (e21 e22 : ty_environment g2)
  (re1 : rel_environment e11 e12) (re2 : rel_environment e21 e22)
  t1 t2 t1' t2',
  JMeq t1 t1' ->
  JMeq t2 t2' ->
  ty_rel (re_app re1 re2) (subst_var g2 g1 (var l) (refl_equal (g1 + 1 + g2)) ty1) t1 t2 =
  rel_lookup_var (var l)
     (re_app
        (re_app re1
           ((fun (H : projT1 (ty_sem_rel ty1) (app e11 e21))
               (H0 : projT1 (ty_sem_rel ty1) (app e12 e22)) =>
             projT2 (ty_sem_rel ty1) (app e11 e21)
               (app e12 e22) (re_app re1 re2) H H0);; rel_nil)) re2) t1' t2'.
intros.
unfold ty_rel in *. unfold ty_sem in *. simpl in *. unfold eq_rec_r in *. simpl.
destruct (lt_eq_lt_dec i g1) as [[X|X]|X]; simpl in *.
 (* i < g1 *)
 revert t1 t2 H H0. generalize (lt_plus_trans i g1 g2 X). intros.
 revert t1' t2' H H0.
 set (Y := rel_lookup l0 (re_app re1 re2) t1 t2).
 set (Y1:=lookup l0 (app e11 e21)). set (Y2:=lookup l0 (app e12 e22)).
 generalize (re_app re1 re2) as re3.
 generalize (app e11 e21) as e31. generalize (app e12 e22) as g32.
 revert ty1. generalize (g1+g2) as g3.
 unfold Y. unfold Y1. unfold Y2. clear Y Y1 Y2.
 intros.
 revert g1 g2 l e11 e12 e21 e22 re1 re2 X l0 t1 t2 t1' t2' H0 H. induction i; intros.
  (* i = 0 *)
  destruct re1.
   (* e1 = ty_nil *)
   elimtype False. inversion X.
   (* e1 = ty_cons *)
   simpl in *. apply f_jmequal2. reflexivity. assumption. assumption.
  (* i > 0 *)
  destruct re1.
   (* e1 = ty_nil *)
   elimtype False. inversion X.
   (* e1 = ty_cons ... *)
   simpl. fold plus. apply IHi with (re1:=re1) (re2:=re2).
    apply lt_S_n. assumption.
    assumption.
    assumption.
 (* i = g1 *)
 revert ty1 t1 t2 t1' t2' H H0.
 generalize (re_app re1 re2) as re3.
 generalize (app e11 e21) as e31.
 generalize (app e12 e22) as e32.
 generalize (g1 + g2) as g3.
 intros.
 revert g1 g2 l e11 e12 e21 e22 re1 re2 t1 t2 t1' t2' H0 H X. induction i; intros.
  (* i = 0 *)
  destruct re1.
   (* e1 = ty_nil *)
   simpl in *. rewrite H0. rewrite H. reflexivity.
   (* e1 = ty_cons *)
   elimtype False. inversion X.
  (* i > 0 *)
  destruct re1.
   (* e1 = ty_nil *)
   elimtype False. inversion X.
   (* e1 = ty_cons *)
   simpl in *. fold plus in *. apply IHi with (re1:=re1) (re2:=re2).
    assumption.
    assumption.
    inversion X. reflexivity.
 (* g1 < i *)
 destruct (O_or_S i) as [[i' i'_Si]|i_0].
  (* i = S i' *)
  simpl in *.
  revert t1 t2 H H0. match goal with [|-forall (_ : lookup ?X _), _ ] => generalize X end. intros.
  revert ty1 t1' t2' H H0.
  set (Y:=rel_lookup l0 (re_app re1 re2) t1 t2).
  set (Y1:=lookup l0 (app e11 e21)). set (Y2:=lookup l0 (app e12 e22)).
  generalize (re_app re1 re2) as re3.
  generalize (app e11 e21) as e31.
  generalize (app e12 e22) as e32.
  generalize (g1 + g2) as g3.
  unfold Y. unfold Y1. unfold Y2. clear Y Y1 Y2.
  intros.
  subst i.
  revert g1 g2 l0 l e11 e12 e21 e22 re1 re2 t1 t2 t1' t2' H H0 X.
  induction i'; intros.
   (* i' = 0 *)
   destruct re1.
    (* e1 = ty_nil *)
    simpl in l0,l.
    assert (lt_S_n 0 g2 l=l0) by apply proof_irrelevance.
    simpl. apply f_jmequal2.
     rewrite H1. reflexivity.
     assumption.
     assumption.
    (* e1 = ty_cons *)
    elimtype False. inversion X. inversion H2.
   (* i' > 0 *)
   destruct re1.
    (* e1 = ty_nil *)
    simpl in *.
    assert (lt_S_n (S i') g2 l=l0) by apply proof_irrelevance.
    apply f_jmequal2.
     rewrite H1. reflexivity.
     assumption.
     assumption.
    (* e1 = ty_cons *)
    simpl re_app. simpl rel_lookup. fold plus.
    eapply IHi' with (l:=lt_S_n (S i') (n + 1 + g2) l) (re1:=re1) (re2:=re2).
     assumption.
     assumption.
     apply lt_S_n. assumption.
  (* i = 0 *)
  elimtype False. clear t1 t2 t1' t2' H H0. subst i. inversion X.
Save.

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

Lemma ty_env_eq : forall g1 g2 ty (e1 : ty_environment g1) (e2 : ty_environment g2) (A A':Set),
  A = A' ->
  ty_sem (app (app e1 (A;:ty_nil)) e2) ty = ty_sem (app (app e1 (A';:ty_nil)) e2) ty.
intros. subst. reflexivity.
Save.

Lemma rel_env_eq : forall g1 g2 ty (e11 e21 : ty_environment g1) (e12 e22 : ty_environment g2)
  (re1 : rel_environment e11 e21) (re2 : rel_environment e12 e22) (A1 A1' A2 A2':Set)
  (R : A1 -> A2 -> Prop) (R' : A1' -> A2' -> Prop)
  t1 t2
  t1' t2',
  A1 = A1' ->
  A2 = A2' ->
  (forall t1 t2 t1' t2', JMeq t1 t1' -> JMeq t2 t2' -> R t1 t2 = R' t1' t2') ->
  JMeq t1 t1' ->
  JMeq t2 t2' ->
  ty_rel (re_app (re_app re1 (R;;rel_nil)) re2) ty t1 t2 =
  ty_rel (re_app (re_app re1 (R';;rel_nil)) re2) ty t1' t2'.
intros. subst.
assert (R=R'). ext x. ext y. apply H1; reflexivity.
rewrite H. rewrite H2. rewrite H3. reflexivity.
Save.

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

Ltac fold_ty_sem :=
  match goal with
    [|-context [ projT1 (ty_sem_rel ?TY) ?E ] ] => change (projT1 (ty_sem_rel TY) E) with (ty_sem E TY)
  end.

Definition subst_sem_rel : forall g1 g2 ty1 ty2,
  (forall (e1 : ty_environment g1) (e2 : ty_environment g2),
         ty_sem (app e1 e2) (subst g2 g1 ty1 ty2) = ty_sem (app (app e1 (ty_sem (app e1 e2) ty1;:ty_nil)) e2) ty2)
  /\
  (forall (e11 e12 : ty_environment g1) (e21 e22 : ty_environment g2)
          (re1 : rel_environment e11 e12) (re2 : rel_environment e21 e22) t1 t2 t1' t2',
                  JMeq t1 t1' ->
                  JMeq t2 t2' ->
                  ty_rel (re_app re1 re2) (subst g2 g1 ty1 ty2) t1 t2 =
                  ty_rel (re_app (re_app re1 (ty_rel (re_app re1 re2) ty1;;rel_nil)) re2) ty2 t1' t2').
intros g1 g2 ty1 ty2. revert ty1. dependent induction ty2.
 (* ty_var *)
 unfold ty_rel. unfold ty_sem. simpl.
 dependent destruction v. split; intros.
  (* types *)
  fold_ty_sem. fold_ty_sem. rewrite <- subst_lookup_var_eq. reflexivity.
  (* relations *)
  rewrite <- subst_lookup_var_rel with (t1:=t1) (t2:=t2); trivial.
 (* ty_arr *)
 intros.
 change (subst g2 g1 ty1 (ty_arr ty2_1 ty2_2)) with (ty_arr (subst g2 g1 ty1 ty2_1) (subst g2 g1 ty1 ty2_2)).
 unfold ty_rel in *. unfold ty_sem in *. simpl in *.
 destruct IHty2_1 with (ty1:=ty1) as [ty_eq1 rel_eq1].
 destruct IHty2_2 with (ty1:=ty1) as [ty_eq2 rel_eq2].
 clear IHty2_1 IHty2_2.
 split; intros.
  (* types *)
  rewrite ty_eq1. rewrite ty_eq2. reflexivity.
  (* relations *)
  apply prop_ext. split.
   (* -> *)
   intros.
   rewrite <- rel_eq2 with (t1:=t1 (coerce (ty_eq1 e11 e21) x1))
                           (t2:=t2 (coerce (ty_eq1 e12 e22) x2)).
    apply H1. rewrite rel_eq1 with (t1':=x1) (t2':=x2).
     apply H2.
     apply coerce_jmeq.
     apply coerce_jmeq.
    apply f_jmequal. apply ty_eq2. assumption. apply coerce_jmeq.
    apply f_jmequal. apply ty_eq2. assumption. apply coerce_jmeq.
   (* <- *)
   intros.
   rewrite rel_eq2 with (t1':=t1' (coerce (sym_eq (ty_eq1 e11 e21)) x1))
                        (t2':=t2' (coerce (sym_eq (ty_eq1 e12 e22)) x2)).
    apply H1. rewrite <- rel_eq1 with (t1:=x1) (t2:=x2).
     apply H2.
     symmetry. apply coerce_jmeq.
     symmetry. apply coerce_jmeq.
    apply f_jmequal. apply ty_eq2. assumption. symmetry. apply coerce_jmeq.
    apply f_jmequal. apply ty_eq2. assumption. symmetry. apply coerce_jmeq.
 (* ty_forall *)
 intros.
 change (subst g2 g1 ty1 (ty_forall ty2)) with (ty_forall (subst g2 (S g1) (shift1 ty1) ty2)).
 destruct (IHty2 (S g1) g2 ty2) with (ty1:=shift1 ty1) as [ty_eq rel_eq]. reflexivity. reflexivity.
 clear IHty2.
 unfold ty_sem in *. unfold ty_rel in *. simpl in *.

 assert (ty_eq':forall (e1 : ty_environment g1) (e2 : ty_environment g2) (A : Set),
                 ty_sem (A;: app e1 e2) (subst g2 (S g1) (shift1 ty1) ty2) =
                 ty_sem (A;: app (app e1 (ty_sem (app e1 e2) ty1;: ty_nil)) e2) ty2).
  intros.
  replace (ty_sem (app e1 e2) ty1) with (ty_sem (A;:app e1 e2) (shift1 ty1)).
   apply (ty_eq (A;:e1) e2).
   symmetry. apply ty_shift1_equal.

 assert (fiddle:forall (e1 : ty_environment g1) (e2 : ty_environment g2) (A : Set),
                  ty_sem (app (app (A;: e1) (ty_sem (A;: app e1 e2) (shift1 ty1);: ty_nil)) e2) ty2
                = ty_sem (app (app (A;: e1) (ty_sem (app e1 e2) ty1;: ty_nil)) e2) ty2).
  intros. symmetry. apply ty_env_eq. apply ty_shift1_equal.

 assert (rel_eq':forall (e1 : ty_environment g1) (e2 : ty_environment g2) a b,
   JMeq a b ->
   (forall (A1 A2 : Set) (R : A1 -> A2 -> Prop),
    projT2 (ty_sem_rel (subst g2 (S g1) (shift1 ty1) ty2))
      (A1;: app e1 e2) (A2;: app e1 e2) (R;; diagonal (app e1 e2))
      (a A1) (a A2)) =
   (forall (A1 A2 : Set) (R : A1 -> A2 -> Prop),
    projT2 (ty_sem_rel ty2)
      (A1;: app (app e1 (projT1 (ty_sem_rel ty1) (app e1 e2);: ty_nil)) e2)
      (A2;: app (app e1 (projT1 (ty_sem_rel ty1) (app e1 e2);: ty_nil)) e2)
      (R;; diagonal (app (app e1 (projT1 (ty_sem_rel ty1) (app e1 e2);: ty_nil)) e2))
      (b A1) (b A2))).
   intros. apply forall_ext. intro A1. apply forall_ext. intro A2. apply forall_ext. intro R.
   rewrite diagonal_app.
   rewrite rel_eq with (re1:=R;;diagonal e1) (re2:=diagonal e2)
                       (t1':=coerce (fiddle e1 e2 A1) (b A1))
                       (t2':=coerce (fiddle e1 e2 A2) (b A2)).
   rewrite diagonal_app. rewrite diagonal_app. simpl.
   apply rel_env_eq with (re1:=R;;diagonal e1) (re2:=diagonal e2)
     (R:=fun (H0 : projT1 (ty_sem_rel (shift1 ty1)) (A1;: app e1 e2))
             (H1 : projT1 (ty_sem_rel (shift1 ty1)) (A2;: app e1 e2)) =>
             projT2 (ty_sem_rel (shift1 ty1)) (A1;: app e1 e2) (A2;: app e1 e2) (R;; re_app (diagonal e1) (diagonal e2)) H0 H1)
     (R':=eq)
     (ty:=ty2)
     (t1':=b A1) (t2':=b A2).
    symmetry. apply ty_shift1_equal.
    symmetry. apply ty_shift1_equal.
    intros. rewrite <- diagonal_app. transitivity (ty_rel (diagonal (app e1 e2)) ty1 t1' t2').
     symmetry. apply ty_rel_shift1_equal.
      symmetry. assumption.
      symmetry. assumption.
     apply prop_ext. apply rel_diagonal.
   apply coerce_jmeq.
   apply coerce_jmeq.
   (*transitivity (b A1).*) eapply JMeq_trans.
    apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A1) (y1:=A1).
     intros. rewrite H0. apply ty_eq'.
     assumption.
     reflexivity.
    symmetry. apply coerce_jmeq.
   (*transitivity (b A2).*) eapply JMeq_trans.
    apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=a) (g:=b) (x1:=A2) (y1:=A2).
     intros. rewrite H0. apply ty_eq'.
     assumption.
     reflexivity.
    symmetry. apply coerce_jmeq.

 split; intros.
  (* types *)
  apply subset_type_eq.
   (* types *)
   apply set_forall_ext. intro A. apply ty_eq'.
   (* relations *)
   apply rel_eq'.
  (* relations *)
  apply forall_ext. intro A1. apply forall_ext. intro A2. apply forall_ext. intro R.
  destruct t1 as [t1 t1_para]. destruct t1' as [t1' t1'_para].
  destruct t2 as [t2 t2_para]. destruct t2' as [t2' t2'_para]. simpl in *.
  rewrite rel_eq with (re1:=R;;re1) (re2:=re2)
                       (t1':=coerce (fiddle e11 e21 A1) (t1' A1))
                       (t2':=coerce (fiddle e12 e22 A2) (t2' A2)).
  apply rel_env_eq with (re1:=R;;re1) (re2:=re2)
     (R  :=fun (H0 : projT1 (ty_sem_rel (shift1 ty1)) (A1;: app e11 e21))
               (H1 : projT1 (ty_sem_rel (shift1 ty1)) (A2;: app e12 e22)) =>
               projT2 (ty_sem_rel (shift1 ty1)) (A1;: app e11 e21) (A2;: app e12 e22) (R;; re_app re1 re2) H0 H1)
     (R' :=fun (H0 : projT1 (ty_sem_rel ty1) (app e11 e21))
               (H1 : projT1 (ty_sem_rel ty1) (app e12 e22)) =>
               projT2 (ty_sem_rel ty1) (app e11 e21) (app e12 e22) (re_app re1 re2) H0 H1)
     (ty :=ty2).
   symmetry. apply ty_shift1_equal.
   symmetry. apply ty_shift1_equal.
   intros. symmetry. apply ty_rel_shift1_equal.
    symmetry. assumption.
    symmetry. assumption.
   apply coerce_jmeq.
   apply coerce_jmeq.
   eapply JMeq_trans. (*transitivity (t1' A1).*)
    apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=t1) (g:=t1') (x1:=A1) (y1:=A1).
     intros. rewrite H1. apply ty_eq'.
     refine (jmeq_exist _ _ H).
      apply set_forall_ext. intro A'. apply ty_eq' with (e1:=e11) (e2:=e21).
      apply rel_eq'.
     reflexivity.
    symmetry. apply coerce_jmeq.
   (*transitivity (t2' A2).*) eapply JMeq_trans.
    apply f_jmequal_type with (A1:=Set) (A1':=Set) (f:=t2) (g:=t2') (x1:=A2) (y1:=A2).
     intros. rewrite H1. apply ty_eq'.
     refine (jmeq_exist _ _ H0).
      apply set_forall_ext. intro A'. apply ty_eq' with (e1:=e12) (e2:=e22).
      apply rel_eq'.
     reflexivity.
    symmetry. apply coerce_jmeq.
Save.

Definition type_subst1_sem : forall g ty1 ty2 (e:ty_environment g),
  ty_sem (ty_sem e ty2;:e) ty1 -> ty_sem e (type_subst1 ty1 ty2).
intros. refine (coerce _ H).
destruct (subst_sem_rel 0 g ty2 ty1) as [ty_eq _]. apply (ty_eq ty_nil).
Defined.

Lemma type_subst1_equal : forall g ty1 ty2 (e:ty_environment g),
  ty_sem (ty_sem e ty2;:e) ty1 = ty_sem e (type_subst1 ty1 ty2).
intros.
destruct (subst_sem_rel 0 g ty2 ty1) as [ty_eq _].
symmetry.
apply (ty_eq ty_nil e).
Save.

Lemma type_subst1_rel : forall g ty1 ty2 (e1 e2:ty_environment g) re
  (x1 : forall A : Set, ty_sem (A;:e1) ty1)
  (x2 : forall A : Set, ty_sem (A;:e2) ty1),
  ty_rel (ty_rel re ty2;;re) ty1 (x1 (ty_sem e1 ty2)) (x2 (ty_sem e2 ty2)) ->
  ty_rel re (type_subst1 ty1 ty2)
    (type_subst1_sem ty1 ty2 e1 (x1 (ty_sem e1 ty2)))
    (type_subst1_sem ty1 ty2 e2 (x2 (ty_sem e2 ty2))).
intros.
unfold type_subst1_sem.
unfold type_subst1.
destruct (subst_sem_rel 0 g ty2 ty1) as [ty_eq rel_eq].
rewrite rel_eq with (re1:=rel_nil) (re2:=re)
                    (t1':=x1 (ty_sem e1 ty2))
                    (t2':=x2 (ty_sem e2 ty2)).
 simpl. apply H.
 apply coerce_jmeq.
 apply coerce_jmeq.
Save.

Lemma rel_subst1_equal :
  forall g ty1 ty2 (e1 e2 : ty_environment g)
  (re : rel_environment e1 e2) t1 t2 t1' t2',
  JMeq t1 t1' ->
  JMeq t2 t2' ->
  ty_rel (ty_rel re ty1;;re) ty2 t1' t2' =
  ty_rel re (type_subst1 ty2 ty1) t1 t2.
intros.
destruct (subst_sem_rel 0 g ty1 ty2).
symmetry.
apply (H2 ty_nil ty_nil e1 e2 rel_nil).
assumption.
assumption.
Save.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language LibTactics.
Require Import Strings.String.
Require Import Program.Tactics.
Require Import SubAndTopLike Appsub.
Require Import Psatz. (* lia *)

Ltac ind_typ_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with
         | [ h : typ |- _ ] => (gen h)
         end;
  induction i as [|i IH]; [
      intros; match goal with
              | [ H : _ < 0 |- _ ] => (dependent destruction H)
              end
    | intros ].

Lemma split_decrease_size:
  forall A B C,
    splitable A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A.
Proof.
  introv H. dependent induction H; simpl; lia.
Qed.

Theorem disjoint_complete :
  forall A B, disjoint A B -> disjoint_spec A B.
Proof.
  intros A B Hdisj C Hsub1 Hsub2.
  ind_typ_size (size_typ A + size_typ B + size_typ C).
  destruct (split_or_ord C).
  - dependent destruction Hdisj; try solve [eapply sub_toplike_preservation; eauto 3].
    + dependent destruction Hsub1.
      * eapply sub_toplike_preservation; eauto.
      * exfalso. eapply split_and_ord; eauto.
      * simpl in SizeInd.
        assert ((size_typ A1 + size_typ B + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj1 _ Hsub1 Hsub2 H1).
      * simpl in SizeInd.
        assert ((size_typ A2 + size_typ B + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj2 _ Hsub1 Hsub2 H1).
    + dependent destruction Hsub2.
      * eapply sub_toplike_preservation; eauto.
      * exfalso. eapply split_and_ord; eauto.
      * simpl in SizeInd.
        assert ((size_typ A + size_typ B1 + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj1 _ Hsub1 Hsub2 H1).
      * simpl in SizeInd.
        assert ((size_typ A + size_typ B2 + size_typ C) < i) by lia.
        now pose proof (IH _ _ Hdisj2 _ Hsub1 Hsub2 H1).
    + dependent destruction Hsub1; dependent destruction Hsub2; eauto 3.
      * inversion H.
      * dependent destruction H.
        exfalso. eapply split_and_ord; eauto.
      * exfalso. eapply split_and_ord; eauto.
    + dependent destruction Hsub1; dependent destruction Hsub2; eauto 3.
      * exfalso. eapply split_and_ord; eauto.
      * inversion H.
      * exfalso. eapply split_and_ord; eauto.
    + dependent destruction Hsub1; dependent destruction Hsub2; eauto 3.
      * constructor. eapply IH.
        eapply Hdisj. eapply Hsub1_2. eapply Hsub2_2.
        simpl in SizeInd. lia.
      * exfalso. eapply split_and_ord; eauto.
      * exfalso. eapply split_and_ord; eauto.
      * exfalso. eapply split_and_ord; eauto.
  - destruct_conjs.
    dependent destruction Hsub1; dependent destruction Hsub2;
      try solve [exfalso; eapply split_and_ord; eauto].
    eapply split_determinism in H0; eauto 3. destruct_conjs. subst.
    eapply split_determinism in H; eauto 3. destruct_conjs. subst.
    pose proof (split_decrease_size _ _ _ H3).
    destruct_conjs.
    eapply toplike_spl_combine; eauto 3.
    + eapply IH; eauto 3. lia.
    + eapply IH; eauto 3. lia.
Qed.

Lemma disjoint_symmetry:
  forall (A B : typ),
    disjoint A B -> disjoint B A.
Proof.
  introv H.
  dependent induction H; eauto.
Qed.

Lemma disjoint_soundness :
  forall (A B : typ),
    disjoint_spec A B -> disjoint A B.
Proof.
  introv. unfold disjoint_spec.
  gen B. induction A; introv H; induction B; eauto.
  - assert (sub typ_int typ_int) by eauto.
    pose proof (H typ_int H0 H0).
    inversion H1.
  - eapply disjoint_and_r; eauto with subtyping.
  - eapply disjoint_arr_arr.
    eapply IHA2. intros.
    assert (toplike (typ_arrow (typ_and A1 B1) C)) by (eapply H; eauto with subtyping).
    now dependent destruction H2.
  - eapply disjoint_and_r; eauto with subtyping.
  - eapply disjoint_and_l; eauto with subtyping.
  - eapply disjoint_and_l; eauto with subtyping.
  - eapply disjoint_and_l; eauto with subtyping.
Qed.

Lemma disjoint_sub :
  forall (A B C : typ),
    disjoint A B -> sub A C -> disjoint C B.
Proof.
  introv Hdisj Hsub.
  eapply disjoint_complete in Hdisj.
  eapply disjoint_soundness.
  unfold disjoint_spec in *. intros.
  eapply Hdisj; eauto.
  eapply sub_transitivity; eauto.
Qed.

Lemma disjoint_iso_transitivity :
  forall (A B C : typ),
    disjoint A B -> isomorphic A C -> disjoint C B.
Proof.
  introv Hdisj Hiso.
  eapply iso_to_sub in Hiso.
  eapply disjoint_sub; eauto.
Qed.

Lemma disjoint_appsub :
  forall (A B C D1 D2 : typ),
    disjoint A B ->
    appsub (Some C) A D1 ->
    appsub (Some C) B D2 ->
    disjoint D1 D2.
Proof.
  introv Hdisj Has1 Has2.
  gen C D1 D2.
  induction Hdisj; intros.
  - inversion Has1.
  - inversion Has2.
  - dependent destruction Has1; eauto.
  - dependent destruction Has2; eauto.
  - inversion Has1.
  - inversion Has2.
  - dependent destruction Has1. dependent destruction Has2.
    eauto.
Qed.

Lemma disjoint_spec_toplike :
  forall (A B : typ),
    toplike A -> disjoint_spec A B.
Proof.
  introv Htl.
  unfold disjoint_spec.
  introv Hsub1 Hsub2.
  eapply sub_toplike_preservation; eauto.
Qed.

Lemma disjoint_toplike :
  forall (A B : typ),
    toplike A -> disjoint A B.
Proof.
  introv Htl.
  assert (disjoint_spec A B) by (eapply disjoint_spec_toplike; eauto).
  now eapply disjoint_soundness in H.
Qed.

Lemma disjoint_split_l :
  forall (A A1 A2 B : typ),
    splitable A A1 A2 ->
    disjoint A B ->
    disjoint A1 B /\ disjoint A2 B.
Proof.
  introv Hspl Hdisj.
  gen A1 A2. dependent induction Hdisj; intros; try solve [inversion Hspl | eauto 3].
  - dependent destruction Hspl.
    split; eauto.
  - pose proof (IHHdisj1 _ _ Hspl).
    pose proof (IHHdisj2 _ _ Hspl).
    destruct_conjs. eauto.
  - dependent destruction Hspl; eauto.
  - dependent destruction Hspl; eauto.
    pose proof (IHHdisj _ _ Hspl).
    destruct H; eauto.
Qed.

Lemma disjoint_split_r :
  forall (A A1 A2 B : typ),
    splitable A A1 A2 ->
    disjoint B A ->
    disjoint B A1 /\ disjoint B A2.
Proof.
  introv Hspl Hdisj.
  gen A1 A2. dependent induction Hdisj; intros; try solve [inversion Hspl | eauto 3].
  - pose proof (IHHdisj1 _ _ Hspl).
    pose proof (IHHdisj2 _ _ Hspl).
    destruct_conjs. eauto.
  - dependent destruction Hspl; eauto.
  - dependent destruction Hspl; eauto.
  - dependent destruction Hspl.
    pose proof (IHHdisj _ _ Hspl).
    destruct_conjs; eauto.
Qed.

Lemma disjoint_iso_l1 :
  forall (A C1 C2: typ),
    disjoint C1 C2 ->
    isomorphic A C1 ->
    disjoint A C2.
Proof.
  introv Hdisj Hiso.
  gen C2. dependent induction Hiso; intros; eauto.
  eapply disjoint_split_l in Hdisj; eauto.
  destruct Hdisj; eauto.
Qed.

Lemma disjoint_iso_l2 :
  forall (B C1 C2: typ),
    disjoint C1 C2 ->
    isomorphic B C2 ->
    disjoint C1 B.
Proof.
  introv Hdisj Hiso.
  gen C1. dependent induction Hiso; intros; eauto.
  eapply disjoint_split_r in Hdisj; eauto.
  destruct Hdisj; eauto.
Qed.

Lemma disjoint_iso_l :
  forall (A B C1 C2 : typ),
    disjoint C1 C2 ->
    isomorphic A C1 ->
    isomorphic B C2 ->
    disjoint A B.
Proof.
  introv Hdisj Hiso1 Hiso2.
  assert (disjoint A C2).
  eapply disjoint_iso_l1; eauto.
  eapply disjoint_iso_l2; eauto.
Qed.

Lemma disjoint_iso_r :
  forall (A B C1 C2 : typ),
    disjoint A B ->
    isomorphic A C1 ->
    isomorphic B C2 ->
    disjoint C1 C2.
Proof.
  introv Hdisj Hiso1 Hiso2.
  assert (disjoint C1 B).
  eapply disjoint_iso_transitivity; eauto.
  eapply disjoint_symmetry.
  eapply disjoint_symmetry in H.
  eapply disjoint_iso_transitivity; eauto.
Qed.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Extensionality.
Require Import BBST.Axiom.Replacement.
Require Import BBST.Definition.Emptyset.
Require Import BBST.Definition.Singleton.
Require Import BBST.Definition.BinaryUnion.
Require Import BBST.Definition.BinaryIntersect.
Require Import BBST.Definition.Function.
Require Import BBST.Definition.Restriction.
Require Import BBST.Lemma.BasicFunction.

Lemma 函数之二元并 : ∀ f g, 为函数 f → 为函数 g →
  (∀x ∈ dom f ∩ dom g, f[x] = g[x]) ↔ 为函数 (f ∪ g).
Proof with eauto.
  intros * Hf Hg. split; intros.
  - split.
    + (* 为序偶集 *) intros p Hp. apply 二元并除去 in Hp as [].
      apply Hf in H0... apply Hg in H0...
    + (* 单值 *) intros x y z Hxy Hxz.
      apply 二元并除去 in Hxy as [];
      apply 二元并除去 in Hxz as []; [eapply Hf| | |eapply Hg]...
      * 函数|-H0. 函数|-H1. apply H. apply 二元交介入; 域.
      * 函数|-H0. 函数|-H1. symmetry. apply H. apply 二元交介入; 域.
  - apply 二元交除去 in H0 as []. 函数 H0... 函数 H1...
    eapply H. apply 左并介入... apply 右并介入...
Qed.

Lemma 函数之二元并之定义域 : ∀ f g, 为函数 f → 为函数 g →
  dom (f ∪ g) = dom f ∪ dom g.
Proof with auto.
  intros * Hf Hg. 外延.
  - 定|-H as [y H]. apply 二元并除去 in H as [].
    apply 左并介入. 域. apply 右并介入. 域.
  - apply 二元并除去 in H as [].
    + 定|-H as [y H]. 定-|y. apply 左并介入...
    + 定|-H as [y H]. 定-|y. apply 右并介入...
Qed.

Lemma 函数加点 : ∀ f a b, 为函数 f → a ∉ dom f → 为函数 (f ∪ {<a, b>,}).
Proof with eauto.
  intros f a b Hf 域外.
  apply 函数之二元并... apply 单点集为函数.
  intros x Hx. exfalso. apply 二元交除去 in Hx as [].
  rewrite 单点集的定义域 in H0. apply 单集除去 in H0; subst...
Qed.

Lemma 函数加点之定义域 : ∀ f a b, dom (f ∪ {<a, b>,}) = dom f ∪ {a,}.
Proof with eauto.
  intros f a b. 外延.
  - 定|-H as [y H]. apply 二元并除去 in H as [].
    + 定 H. apply 左并介入...
    + apply 单集除去 in H. apply 序偶相等 in H as []; subst...
  - apply 二元并除去 in H as [].
    + 定|-H as [y H]. 定-|y. apply 左并介入...
    + apply 单集除去 in H. subst. 定-|b. apply 右并介入...
Qed.

Lemma 函数加点之左应用 : ∀ f a b, 为函数 f → a ∉ dom f → ∀x ∈ dom f, (f ∪ {<a, b>,})[x] = f[x].
Proof. intros. apply 函数应用. apply 函数加点; auto. apply 左并介入. 函数-|. Qed.

Lemma 函数加点之右应用 : ∀ f a b, 为函数 f → a ∉ dom f → (f ∪ {<a, b>,})[a] = b.
Proof. intros. apply 函数应用. apply 函数加点; auto. apply 右并介入; auto. Qed.

Lemma 函数加点之左限制 : ∀ f a b, 为函数 f → a ∉ dom f → (f ∪ {<a, b>,}) ↾ (dom f) = f.
Proof with auto.
  intros f a b Hf 域外. 外延 x Hx.
  - 序偶分离|-Hx. apply 二元并除去 in Hp as []...
    apply 单集除去 in H. apply 序偶相等 in H as []; subst. easy.
  - 函数|-Hx. 序偶分离-|... 域.
Qed.

Lemma 函数加点之右限制 : ∀ f a b, 为函数 f → a ∉ dom f → (f ∪ {<a, b>,}) ↾ {a,} = {<a, b>,}.
Proof with auto.
  intros f a b Hf 域外. 外延 x Hx.
  - 序偶分离|-Hx. apply 二元并除去 in Hp as []...
    apply 单集除去 in Hx; subst. 定 H. easy.
  - apply 单集除去 in Hx; subst. 序偶分离-|...
Qed.

Lemma 函数集族并之定义域 : ∀ F A, dom (⋃ {F x | x ∊ A}) = ⋃ {dom (F x) | x ∊ A}.
Proof with auto.
  intros. 外延 x Hx.
  - 定|-Hx as [y Hp]. apply 集族并除去 in Hp as [a [Ha Hp]].
    apply 集族并介入 with a... 域.
  - apply 集族并除去 in Hx as [a [Ha Hp]]. 定|-Hp as [y Hp].
    定-|y. apply 集族并介入 with a...
Qed.


(* begin hide *)
Require Import Coq.Structures.OrderedType.
Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.FSets.FSetAVL.
Require Import Coq.FSets.FMapAVL.
Require Coq.FSets.FMapFacts.
Require Coq.FSets.FSetProperties.
Require Import Aniceto.Map.
Require Import Aniceto.Set.

Module TID := Nat_as_OT.
Module TID_Facts := OrderedTypeFacts TID.
Module Set_TID := FSetAVL.Make TID.
Module Set_TID_Props := FSetProperties.Properties Set_TID.
Module Set_TID_Extra := SetUtil Set_TID.
Module Map_TID := FMapAVL.Make TID.
Module Map_TID_Facts := FMapFacts.Facts Map_TID.
Module Map_TID_Props := FMapFacts.Properties Map_TID.
Module Map_TID_Extra := MapUtil Map_TID.

Definition tid := TID.t.
Definition set_tid := Set_TID.t.

Module PHID := Nat_as_OT.
Module Set_PHID := FSetAVL.Make PHID.
Module Set_PHID_Extra := SetUtil Set_PHID.
Module Map_PHID := FMapAVL.Make PHID.
Module Map_PHID_Facts := FMapFacts.Facts Map_PHID.
Module Map_PHID_Props := FMapFacts.Properties Map_PHID.
Module Map_PHID_Extra := MapUtil Map_PHID.

Definition phid := PHID.t.
Definition set_phid := Set_PHID.t.

(* end hide *)


Require Import MyTacs HoTT.
Require Import Peano nat_lemmas equivalence cech_nerve colimit colimit2.

Set Implicit Arguments.

Context `{fs : Funext}.
Context `{ua : Univalence}.

(* Squash *)
Notation sq A := (@tr -1 A).

(* We want to prove that [Trunc -1 A] is the colimit of the Cech nerve of [sq: A -> Trunc -1 A]. *)

Section Prod_diagram.

  (* We prove here that we can use the real diagram A×...×A -> ... -> A×A -> A instead of the Cech nerve of sq with irrelevant second compenents *)

  Lemma ishprop_pullback_sq_pr2
        (A : Type)
        (i : nat)
        (x : ∃ P : A ∧ hProduct A i, char_hPullback (sq A) i P)
  : IsHProp
      (char_hPullback (sq A) i x.1).
    induction i; simpl.
    apply true_ishprop.
    refine (trunc_prod). simpl in *.
    exact (IHi (snd x.1; snd x.2)).
  Qed.

  Definition prod_diag (A:Type) : diagram Cech_nerve_graph.
    refine (Build_diagram _ _ _).
    - simpl. intro i. exact (hProduct A (S i)).
    - simpl. intros i j [f q]. destruct f. intros x.
      exact (forget_hProduct A (S j) x q).
  Defined.

  Definition CN_sq_cocone {A Q: Type} (C: cocone (prod_diag A) Q)
  : cocone (Cech_nerve_diagram (sq A)) Q.
    refine (exist _ _ _); simpl.
    - intros i X. apply (C.1 i). exact X.1.
    - intros i j [f [k Hk]] x; destruct f; simpl.
      exact (C.2 (j.+1) j (idpath,(k;Hk)) x.1).
  Defined.

  Lemma inhab_pullback_sq_pr2 (A:Type) (i:nat)
  : forall x:A*(hProduct A i), char_hPullback (sq A) i x.
    intro x.
    induction i. exact tt. simpl.
    refine (pair _ _).
    apply path_ishprop.
    apply IHi.
  Qed.

  Lemma colim_prod_diag_CN_sq (A:Type) Q (C : cocone (prod_diag A) Q)
  : is_colimit C -> is_colimit (CN_sq_cocone C).
    intros H.
    refine (transport_is_colimit _ _ _ _ _ _ _ _ _ _ _ _ H); simpl.
    - intro i. refine (equiv_adjointify _ _ _ _).
      + intros x. exists x. apply inhab_pullback_sq_pr2.
      + exact pr1.
      + intros x. apply path_sigma' with idpath.
        simpl. refine (path_ishprop _ _). apply ishprop_pullback_sq_pr2.
      + intros x. reflexivity.
    - intros i j [f [q Hq]]; destruct f; simpl.
      intro x; reflexivity.
    - reflexivity.
    - simpl.
      apply path_forall; intro i.
      apply path_forall; intro j.
      apply path_forall; intros [f [q Hq]]; destruct f.
      apply path_forall; intro x. simpl. hott_simpl.
      unfold path_sigma'.
      pose (p := @pr1_path_sigma). unfold pr1_path in p. rewrite p.
      rewrite ap_1. rewrite concat_p1. reflexivity.
  Qed.

End Prod_diagram.

Section TheProof.

  Open Scope path_scope.
  Open Scope type_scope.

  (* Sketch of proof :
     Let [Q] be the colimit of [prod_diag A].
     As [Trunc -1 A] defines a cocone on [prod_diag A], we have an arrow [Q -> Trunc -1 A].
     As there is an arrow [A -> Q], it remains to show that [IsHProp Q], so that we have an arrow [Trunc -1 A -> Q] defining an equivalence ([Q] and [Trunc -1 A]) are both [HProp]). *)

  (* To show [IsHProp Q], it suffices to show that : *)
  Lemma HProp_if_snd_equiv (Q:Type)
  : IsEquiv (snd : Q*Q -> Q) -> IsHProp Q.
  Proof.
    intro H.
    apply hprop_allpath; intros u v.
    assert (X : (u,u) = (v,u)).
    { apply (@equiv_inj _ _ _ H). reflexivity. }
    exact (ap fst X).
  Qed.

  Variable (A:Type).
  Let D := prod_diag A.
  (* Let D' := Cech_nerve_diagram (sq A). *)
  Variable Q : Type.
  Variable C : cocone D Q.
  Variable (colimQ : is_colimit C).

  Let pi := @snd Q A.

  Lemma C2 (D' := pdt_diagram_l D Q)
  : cocone D' Q.
    refine (exist _ _ _).
    - simpl. intros i [a [x y]]. exact ((C.1 i) (pi (a,x), y)).
    - intros i j f x; destruct (fst f); simpl in *.
      exact (C.2 (j.+1) j f _).
  Defined.

  (* Using the fact that [Q ∧ Q = Q ∧ (colimit D], we have: *)
  Lemma isequiv_snd_QQ_if_isequiv_snd_QA (D' := pdt_diagram_l D Q)
  : IsEquiv (pi : Q ∧ A -> A) -> IsEquiv (snd : Q ∧ Q -> Q).
    intro H.
    specialize (colimit_product_l Q colimQ); intros colimQQ.
    set (C1 := pdt_cocone_l Q C) in *.
    unfold is_colimit in colimQQ.
    assert (eq: @snd Q Q  = (map_to_cocone C1 Q)^-1 C2).
    { apply (equiv_inj (map_to_cocone C1 Q)).
      rewrite eisretr.
      refine (path_cocone _ _).
      + intros i x. reflexivity.
      + intros i j [f [q Hq]] x; destruct f; simpl.
        rewrite concat_p1; rewrite concat_1p.
        apply (ap_snd_path_prod (z := (fst x, C.1 j _))
                                (z' := (fst x, C.1 j.+1 (snd x)))
                                1 (C.2 j.+1 j (1, (q; Hq)) (snd x))).
      }
    rewrite eq; clear eq.
    apply (colimit_unicity colimQQ).
    refine (transport_is_colimit _ _ _ _ _ _ _ _ _ _ _ _ colimQ).
    - intros i. simpl.
      symmetry.
      transitivity ((Q ∧ A) ∧ hProduct A i).
      apply equiv_prod_assoc. apply equiv_functor_prod_r. refine (BuildEquiv _ _ _ H).
    - intros i j [f [q Hq]] x; destruct f. simpl.
      exact (ap
               (λ x : A ∧ A ∧ hProduct A j,
                      (nat_rect (λ p : nat, p <= j.+1 → A ∧ hProduct A j)
                                (λ _ : 0 <= j.+1, (fst (snd x), snd (snd x)))
                                (λ (p : nat) (_ : p <= j.+1 → A ∧ hProduct A j)
                                   (H : p.+1 <= j.+1),
                                 (fst x,
                                  forget_hProduct A j (fst (snd x), snd (snd x))
                                                  (p; le_pred p.+1 j.+1 H))) q Hq))
               (path_prod' (y' := snd x) (eisretr pi (fst x)) 1)^).
    - reflexivity.
    - simpl.
      apply path_forall; intro i.
      apply path_forall; intro j.
      apply path_forall; intros [f [q Hq]].
      apply path_forall; intro x.
      destruct f; simpl. hott_simpl.
      match goal with
        |[|- (ap ?X1 (ap ?X2 ?X3) @ _) @ _ = _ ] =>
         rewrite <- (ap_compose X2 X1 X3)
      end.
      rewrite ap_V. rewrite concat_pp_p.
      apply moveR_Vp.
      exact (concat_Ap (C.2 (j.+1) j (1,(q;Hq))) (path_prod' (eisretr pi (fst x)) 1))^.
  Defined.

  Lemma le_1_Sn (n:nat) : 1 <= S n.
    induction n. auto.
    apply le_S. exact IHn.
  Qed.

  Lemma isequiv_snd_QA
  : IsEquiv (pi : Q ∧ A -> A).
    refine (isequiv_adjointify _ _ _ _).
    - exact (λ x, (C.1 0 (x, tt), x)).
    - intros x. reflexivity.
    - intros x. apply path_prod; [simpl|reflexivity].
      generalize x; apply ap10.
      specialize (colimit_product_r A colimQ); intros colimQA. unfold is_colimit in *.
      refine (equiv_inj (map_to_cocone (pdt_cocone_r A C) Q) _).
      refine (path_cocone _ _).
      + intros i [[z z'] a]. simpl in *.
        induction i.
        * destruct z'; simpl.
          etransitivity; [exact (C.2 1%nat 0 (1,(1%nat; le_n 1)) (a, (z, tt))) | exact (C.2 1%nat 0 (1,(0; le_0 _)) (a, (z, tt)))^].
        * etransitivity; [exact (IHi (snd z')) | idtac].
          etransitivity; [idtac | exact (C.2 (i.+1) i (1,(1%nat; le_1_Sn _)) (z,z'))].
          apply ap. refine (path_prod _ _ _ _).
          reflexivity.
          destruct i; [apply path_ishprop | reflexivity].
      + intros i j [f [q Hq]] u; destruct f; simpl.
        match goal with
            |[|- ?PP @ _ = _] => assert (X : 1 = PP)
          end.
        { unfold path_prod'. simpl.
          rewrite (ap_compose pi (λ x, C.1 0 (x,tt))).
          unfold pi. rewrite ap_snd_path_prod. reflexivity. }
        destruct X; rewrite concat_1p.
        match goal with
            |[|- _ = _ @ ?PP] => assert (X : (C.2 j.+1 j (1, (q; Hq)) (fst u)) = PP)
          end.
          { unfold path_prod'. simpl.
            rewrite ap_fst_path_prod. reflexivity. }
          destruct X.

        induction j; simpl.
        * destruct u as [[u1 [u2 u]] v]. simpl in *.
          destruct u.
          destruct (le_1_is_01 q Hq).
          symmetry in p; destruct p. simpl.
          assert (X : 1 = (path_ishprop tt tt)).
          { apply path_ishprop. }
          destruct X. simpl; rewrite concat_1p.
          assert (X : le_0 1 = Hq).
          { refine (path_ishprop _ _). apply IsHProp_le. }
          destruct X.
          apply moveR_pM.
          rewrite concat_pp_p.
          pose (C.2 1%nat 0 (1, (1%nat; le_n 1)) (v, (u1, tt))). simpl in p.
          pose ((C.2 1%nat 0 (1, (0; le_0 1)) (v, (u1, tt)))^). simpl in p0.
          shelve.
          symmetry in p; destruct p; simpl.
Admitted.

End TheProof.

Section AnotherAtempt.

  Definition delta : graph.     (* = Cech_nerve_graph *)
    refine (Build_graph nat _).
    intros i j. exact ((S j = i) /\ (nat_interval i)).
  Defined.

  Definition delta_plus: graph.
    refine (Build_graph nat _).
    intros i j. exact ((S j = i) /\ (nat_interval j)).
  Defined.

  Definition augment_diag {A B: Type} (D: diagram delta) (π: A -> B): diagram delta_plus.
    refine (Build_diagram _ _ _).
    - intros i. destruct i. exact B. exact (D i /\ B).
    - intros i j [eq f]. destruct j.
      + destruct eq. exact snd.
      + destruct eq. intros x. exact (diagram1 D (idpath,f) (fst x), snd x).
  Defined.

  Definition augment_cocone {A B: Type} (D: diagram delta) (π: A -> B): cocone (augment_diag D π) B.
    refine (exist _ _ _).
    - intros i. destruct i. exact idmap. exact snd.
    - intros i j [eq f]; destruct eq. destruct j; reflexivity.
  Defined.

  Lemma augment_diag_colimit {A B: Type} (D: diagram delta) (π: A -> B): is_colimit (augment_cocone D π).
    intros X. refine (isequiv_adjointify _ _ _ _).
    - intros C. exact (C.1 0).
    - intros C. refine (path_cocone _ _).
      + destruct i; simpl. intros x; reflexivity.
        induction i. exact (C.2 1 0 (idpath, (0; le_0 _))).
        intros x. etransitivity; [| exact (C.2 (i.+2) (i.+1) (idpath, (0; le_0 _)) x)].
        simpl. exact (IHi (@diagram1 _ D i.+1 i (idpath, (0; le_0 i.+1)) (fst x), snd x)).
      + intros i j [eq f] x; destruct eq.
        destruct j; simpl; hott_simpl.
        * assert (eq: f = (0; le_0 0)).
          { destruct f as [k Hk].
            refine (path_sigma _ _ _ _ _).
            apply le_0_is_0. assumption.
            simpl. refine (path_ishprop _ _).
            apply IsHProp_le. }
          rewrite eq. reflexivity.
        * match goal with
            | [|- ?PP1 @ ?PP2 = ?PP3 @ ?PP4 ] => set (P1 := PP1); set (P2 := PP2); set (P3 := PP3); set (P4 := PP4)
          end. induction j; simpl in *.
          shelve. shelve.
    - intros q. funext b. reflexivity.
  Admitted.

End AnotherAtempt.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                         Factorization_Synth.v                            *)
(****************************************************************************)

Require Export Factorization.

 Section Factorization_for_Synthesis.

   Variable A : Set.
   Variable BASE : BT.
   Let b := base BASE.
   Let Num := num BASE.
   Let Digit := digit BASE.
   Let Val_bound := val_bound BASE.
   Definition Tl := tl Digit.

   Variable FR : forall n : nat, A -> inf n -> inf n -> A.

   Let R (n : nat) (a : A) (x y : inf n) (a' : A) : Prop := a' = FR n a x y.

   Notation Factorizable := (factorizable _) (only parsing).
   Notation Proper := (proper _) (only parsing).

   Theorem factorization_for_synthesis :
    factorizable _ R ->
    proper _ BASE R ->
    forall (n : nat) (X Y : Num n) (a : A),
    {a' : A | R (exp b n) a (Val_bound n X) (Val_bound n Y) a'}.
  intros F P.
  simple induction n.
  intros X Y a.
  exists a.
  simpl in |- *.
  unfold R in |- *; unfold Val_bound in |- *; apply prop_Rel.
  try trivial.
  clear n; intros n H_rec X Y a.
  elim
   (H_rec (Tl (S n) X) (Tl (S n) Y) (FR b a (Hd Digit n X) (Hd Digit n Y))).
  intros a' H; exists a'.
  unfold b in |- *; unfold R in |- *; unfold Val_bound in |- *.
  apply fact_Rel; try trivial.
  Defined.

End Factorization_for_Synthesis.

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