(* 単一化*)

From mathcomp Require Import all_ssreflect.
Require String.
Import String.StringSyntax.

Open Scope string_scope.

(* 変数*)
Definition var := nat.

(* 定数・関数記号*)
Notation symbol := String.string.
Definition symbol_dec := String.string_dec.
(* 自己確認ここから *)
Check String.string_dec : forall s1 s2 : symbol, {s1 = s2} + {s1 <> s2}.
Eval compute in symbol_dec "a" "a".
(*
  = left (erefl "a")
  : {"a" = "a"} + {"a" <> "a"}
*)
(* 自己確認ここまで *)

(* 項は木構造*)
Inductive tree : Set :=
    Var : var -> tree
  | Sym : symbol -> tree
  | Fork : tree -> tree -> tree.

(* 自動的に等価性を生成する*)
Scheme Equality for tree. (* Coq 8.9 で動かないかも*)

(* Scheme Equality が失敗するなら手で定義する*)
Definition tree_eq_dec' (t1 t2 : tree) :
  {t1 = t2}+{t1 <> t2}.
Proof.
  (* 自己確認ここから *)
  revert t2; induction t1; destruct t2; try by right.
  - (* Var *)
    case /boolP: (v == v0) => /eqP H.
    + (* v = v0 *)
      by left; rewrite H.
    + (* v <> v0 *)
      by right; case.
      (*
        case で <> を展開して前提矛盾に持ち込める模様(以下同様)
      *)
  - (* Sym *)
    case (symbol_dec s s0) => H.
    + (* s = s0 *)
      by left; rewrite H.
    + (* s <> s0 *)
      by right; case.
  - (* Fork *)
    case (IHt1_1 t2_1) => [<- | N].
    + (* t1_1 = t2_1 *)
      case (IHt1_2 t2_2) => [<- | N].
      (* ここで case せずに left してしまうと証明できない *)
      * (* t1_2 = t2_2 *)
        by left.
      * (* t1_2 <> t2_2 *)
        by right; case.
    + (* t1_1 <> t2_1 *)
      by right; case.
  Restart.
  (* 自己確認ここまで *)
  revert t2; induction t1; destruct t2; try by right.
  - case /boolP: (v == v0) => /eqP H. by left; rewrite H. by right; case.
  - case (symbol_dec s s0) => H. by left; rewrite H. by right; case.
  - case (IHt1_1 t2_1) => [<-|N]; last by right; case.
  case (IHt1_2 t2_2) => [<-|N']. by left. by right; case.
Defined.

(* tree をeqType として登録する*)
Lemma tree_eq_boolP :
  Equality.axiom tree_eq_dec.
Proof.
  (*
    Equality.axiom (T:=tree) (fun x y : tree => tree_eq_dec x y)
  *)

  Check Equality.axiom : forall T : Type, rel T -> Type.
  Print Equality.axiom.
  (*
    Equality.axiom =
      fun (T : Type) (e : rel T) => forall x y : T, reflect (x = y) (e x y)
           : forall T : Type, rel T -> Type
  *)
  Check tree_eq_dec : forall x y : tree, {x = y} + {x <> y}.
  Check @Equality.axiom tree tree_eq_dec : Type.

  move=> x y.
  case: tree_eq_dec => //= H; by constructor.
Qed.

Definition tree_eq_mixin :=
  EqMixin tree_eq_boolP.

Canonical tree_eqType :=
  Eval hnf in EqType _ tree_eq_mixin.

(* [t/x] t' *)
Fixpoint subs (x : var) (t t' : tree) : tree :=
  match t' with
  | Var v      => if v == x
                  then t
                  else t'
  | Sym b      => Sym b
  | Fork t1 t2 => Fork (subs x t t1) (subs x t t2)
  end.
(* 自己確認ここから *)
(*
  関数subsは、第3引数のツリーt'が
  ・変数だった場合：変数番号が第1引数xに等しかったら、t'をtに置き換えたものを返し、xに等しくなかったらそのまま返す。
  ・シンボルだった場合：そのまま返す。
  ・Forkだった場合：2つの枝t1,t2それぞれを第3引数として、再帰的に関数subsを繰り返し、その結果を2つの枝として持つForkを返す。
  という様な関数らしい。
*)
Eval compute in subs 1 (Sym "a") (Var 1). (* = Sym "a" : tree *)
Eval compute in subs 1 (Sym "a") (Var 2). (* = Var 2 : tree *)
(* 自己確認ここまで *)

(* 代入は変数代入の繰り返し*)
Definition subs_list (s : list (var * tree)) t : tree :=
  foldl (fun t (p : var * tree) => subs p.1 p.2 t) t s.
(* 自己確認ここから *)
(*
  subs_listは、第2引数のツリーtに含まれる各変数について、第1引数の変数とツリーのタプルのリストを順番に参照して、
  変数番号に対応するツリーに置き換える処理を表すらしい。
*)
Eval compute in subs_list [:: (0, Var 2); (1, Var 4)] (Var 0).
(*
  = Var 2 : tree  (* 変数0に割り当てられているのは「Var 2」ということらしい。 *)
 *)
Eval compute in subs_list [:: (0, Var 2); (1, Var 4)] (Var 1).
(*
  = Var 4 : tree  (* 変数1に割り当てられているのは「Var 4」ということらしい。 *)
*)
Eval compute in subs_list [:: (0, Var 2); (1, Var 4)] (Var 2).
(*
  = Var 2 : tree  (* 変数2に割り当てられているtreeは存在しないため、変数2のままということらしい。 *)
*)
Eval compute in subs_list [:: (0, Sym "a"); (1, Sym "b")] (Var 0).
(*
  = Sym "a" : tree  (* 変数0に割り当てられているのは「Sym "a"」ということらしい。 *)
*)
Eval compute in subs_list [:: (0, Sym "a"); (1, Sym "b")] (Var 1).
(*
  = Sym "b" : tree  (* 変数1に割り当てられているのは「Sym "b"」ということらしい。 *)
*)
Eval compute in subs_list [:: (0, Sym "a"); (1, Sym "b")] (Var 2).
(*
  = Var 2 : tree  (* 変数2に割り当てられているtreeは存在しないため、変数2のままということらしい。 *)
*)
Eval compute in subs_list [:: (0, Fork (Var 1) (Var 2)); (1, Fork (Var 3) (Var 4))] (Var 0).
(*
  = Fork (Fork (Var 3) (Var 4)) (Var 2) : tree
  (* 変数0に割り当てられているのは「Fork (Var 1) (Var 2)」であり、
     変数1に割り当てられているのは「Fork (Var 3) (Var 4)」であるため、
     最終的に「Fork (Fork (Var 3) (Var 4)) (Var 2)」になるということらしい。 *)
*)
Eval compute in subs_list [:: (0, Fork (Var 1) (Var 2)); (1, Fork (Var 3) (Var 4))] (Var 1).
(*
  = Fork (Var 3) (Var 4) : tree  (* 変数1に割り当てられているのは「Fork (Var 3) (Var 4)」ということらしい。 *)
*)
Eval compute in subs_list [:: (0, Fork (Var 1) (Var 2)); (1, Fork (Var 3) (Var 4))] (Var 2).
(*
  = Var 2 : tree  (* 変数2に割り当てられているtreeは存在しないため、変数2のままということらしい。 *)
*)
Eval compute in subs_list [:: (0, Fork (Var 1) (Var 2)); (1, Fork (Var 3) (Var 4))] (Var 3).
(*
  = Var 3 : tree  (* 変数3に割り当てられているtreeは存在しないため、変数3のままということらしい。 *)
*)
Eval compute in subs_list [:: (0, Fork (Var 1) (Var 2)); (1, Fork (Var 3) (Var 4))] (Var 4).
(*
  = Var 4 : tree  (* 変数4に割り当てられているtreeは存在しないため、変数4のままということらしい。 *)
*)
(* 自己確認ここまで *)

(* 単一子の定義*)
Definition unifies s (t1 t2 : tree) :=
  subs_list s t1 = subs_list s t2.
(* 例: (a, (x, y)) [x := (y, b)] [y := z] = (a, ((z,b), z)) *)
(* 自己確認ここから *)
(*
  unifiesは、第1引数の変数とツリーのタプルのリストsの元で、第2第3引数のツリーt1,t2の変数を対応するツリーに置き換えたものは等しいという命題を表すらしい。
*)
Eval compute in
    unifies
      [:: (0, Fork (Var 1) (Sym "b")); (1, Var 2)]
      (Fork (Sym "a") (Fork (Var 0) (Var 1)))
      (Fork (Sym "a") (Fork (Fork (Var 1) (Sym "b")) (Var 2))).
(*
  = Fork (Sym "a") (Fork (Fork (Var 2) (Sym "b")) (Var 2)) =
    Fork (Sym "a") (Fork (Fork (Var 2) (Sym "b")) (Var 2))
  : Prop
*)
(* 自己確認ここまで *)
Definition atree :=
  Fork (Sym "a") (Fork (Var 0) (Var 1)).
Definition asubs :=
  (0, Fork (Var 1) (Sym "b")) :: (1, Var 2) :: nil.
Eval compute in subs_list asubs atree.
(*
  = Fork (Sym "a") (Fork (Fork (Var 2) (Sym "b")) (Var 2)) : tree
 *)
(* 自己確認ここから *)
(*
  Check asubs : seq (nat * tree).
*)
(*
  Fork (Sym "a") (Fork (Var 0) (Var 1))
  ↓
  Fork (Sym "a") (Fork (Fork (Var 1) (Sym "b")) (Var 1)))
  ↓
  Fork (Sym "a") (Fork (Fork (Var 2) (Sym "b")) (Var 2)))
  となる模様。
*)
(* 自己確認ここまで *)

(* 和集合*)
Fixpoint union (vl1 vl2 : list var) :=
  if vl1 is v :: vl
  then
    if v \in vl2
    then union vl vl2
    else union vl (v :: vl2)
  else vl2.
(* 自己確認
  関数unionは、リストvl1とvl2を、要素の重複をなくしながら、1つのリストにマージして返す関数らしい。
*)

Lemma in_union_or v vl1 vl2 :
  v \in union vl1 vl2 = (v \in vl1) || (v \in vl2).
(*
  変数vが、変数のリストvl1,vl2の和集合に含まれるかどうかの真偽値と、
  変数vが変数のリストvl1に含まれるかどうかの真偽値と変数vが変数のリストvl2に含まれるかどうかの真偽値の論理和は等しい。
*)
Proof.
  elim: vl1 vl2 => //= x vl IH vl2.
  (*
    vl1 に関する帰納法( vl2 を汎化)
    vl1 が空リストの場合は try done により証明完了
    vl1 が空リストでない( vl1 = x :: vl となる)場合
    ゴールは
    (v \in (if x \in vl2 then union vl vl2 else union vl (x :: vl2))) =
    (v \in x :: vl) || (v \in vl2)
    となる。
    ゴールの左辺は
    x \in vl2 なら v \in union vl vl2
    x \notin vl2 なら v \in union vl (x :: vl2)
    ↓
    (head vl1) \in vl2 なら v \in union (tail vl1) vl2
    (head vl1) \notin vl2 なら v \in union (tail vl1) ((head vl1) :: vl2)
    を意味する模様。
  *)
  (* 追加ここから *)
  rewrite in_cons.
  (*
    ゴールの右辺を
    (v == x) || (v \in vl) || (v \in vl2)
    に書き換え
  *)
  case: ifP => Hx; rewrite IH /=.
  (*
    (x \in vl2) = true or false で場合分け
    if then else が展開されて現れた union vl _ を仮定 IH を使って書き換え
  *)
  - (* (x \in vl2) = true の場合 *)
    case Hv : (v == x) => //=.
    (*
      (v == x) = true or false で場合分け
      (v == x) = false の場合は try done で証明完了
      (v == x) = true の場合
      ゴールは
      (v \in vl) || (v \in vl2) = true
      となる。
      v = x が成り立つので、仮定の x \in vl2 を使えば証明できる。
    *)
    move: Hv => /eqP ->.
    rewrite Hx.
    by apply: orbT.
  - (* (x \in vl2) = false の場合 *)
    by rewrite in_cons Bool.orb_assoc [(v \in vl) || (v == x)]orbC.
  (* 追加ここまで *)
Qed.

(* 完全性のために必要*)
Lemma uniq_union vl1 vl2 :
  uniq vl2 ->
  uniq (union vl1 vl2).
(*
  変数のリストvl2の要素が重複していなければ、変数のリストvl1とvl2の和集合の要素は重複していない。
*)
Proof.
  elim: vl1 vl2 => //=.
  (* 追加ここから *)
  move=> x vl IH vl2 H.
  case: ifP => H'.
  - by apply: (@IH vl2 H).
  - apply: IH.
    rewrite /=.
    move: H' => /negbT H'.
    by apply/andP.
  (* 追加ここまで *)
Qed.

Search _ (uniq _).

(* 出現変数*)
Fixpoint vars (t : tree) : list var :=
  match t with
  | Var x      => [:: x]
  | Sym _      => nil
  | Fork t1 t2 => union (vars t1) (vars t2)
  end.
(* 自己確認ここから *)
(*
  関数varsは、第1引数のツリーtに含まれる変数の番号を、重複をなくしたリストにして返す関数らしい。
*)
Print atree.
(* atree = Fork (Sym "a") (Fork (Var 0) (Var 1)) : tree *)
Eval compute in vars atree.
(* = [:: 0; 1] : seq var *)
(* 自己確認ここまで *)

(* 出現しない変数は代入されない*)
Lemma subs_same v t' t :
  v \notin (vars t) ->
  subs v t' t = t.
(*
  変数vが、ツリーtに含まれる変数のリストに含まれていないならば、
  ツリーtの変数vをツリーt'で置き換えようとしても、結果はtのままである。
*)
Proof.
  elim: t => //= [x | t1 IH1 t2 IH2].
  - by rewrite inE eq_sym => /negbTE ->.
  - by rewrite in_union_or negb_or => /andP[] /IH1 -> /IH2 ->.
Qed.

Definition may_cons (x : var) (t : tree) r :=
  omap (cons (x,t)) r.
(* 自己確認ここから *)
(*
  may_consは、変数xとツリーtのタプルをリストにコンスする関数とリストrをomapに渡す処理を表す模様。
  リストrの型が(var * tree)ならSome、そうでなければNoneということ？
*)
(*
  Check omap
        : forall aT rT : Type,
            (aT -> rT) ->
            option aT ->
            option rT.

  Inductive option (A : Type) : Type :=
    Some : A -> option A
  | None : option A.

  ※optionって、HaskellでのMaybeみたいなもの？
*)
(* 自己確認ここまで *)

Definition subs_pair x t (p : tree * tree) :=
  (subs x t p.1, subs x t p.2).
(* 自己確認ここから *)
(*
  subs_pairは、タプルpの第1要素の変数xをツリーtに置き換えたものを第1要素、タプルの第2要素の変数xをツリーtに置き換えたものを第2要素とするタプルを表す模様。
*)
(* 自己確認ここまで *)

(* 単一化*)
Section Unify1.

  (* 代入を行ったときの再帰呼び出し*)
  Variable unify2 : list (tree * tree) -> option (list (var * tree)).
  (* 自己確認ここから *)
  (*
    unify2は変数名ということだが、型は関数型となる模様。
  *)
  (* 自己確認ここまで *)

  (* 代入して再帰呼び出し. x はt に現れてはいけない*)
  Definition unify_subs x t r :=
    if x \in vars t
    then None
    else may_cons x t (unify2 (map (subs_pair x t) r)).
  (* 自己確認ここから *)
  (*
    unify_subは、
    変数xがツリーtに含まれていればNoneを返し、
    変数xがツリーtに含まれていれば、変数xとツリーtのタプルをリストにコンスする関数と
    リスト(unify2 (map (subs_pair x t) r))をomapに渡して処理した結果を返す処理を表すらしい。
      (subs_pair x t)は、2要素のタプル(2要素ともツリー)を受け取って、
      タプルの各要素の変数xをツリーtで置き換えたタプル((tree * tree)型)を返す関数らしい。
      (map (subs_pair x t) r)は、
      (list (tree * tree))型のリストrに対して(subs_pair x t)を適用した結果得られる(list (tree * tree))型のリストとなる模様。
      (unify2 (map (subs_pair x t) r))は、option (list (var * tree))型となる模様。

    Check unify_subs : nat_eqType -> tree -> seq (tree * tree) -> option (seq (var * tree)).
      x : nat_eqType
      t : tree
      r : seq (tree * tree)
  *)
  (* 自己確認ここまで *)

  (* 代入をせずに分解*)
  Fixpoint unify1 (h : nat) (l : list (tree * tree)) : option (list (var * tree)) :=
    if h is h'.+1
    then
      match l with
      | nil
          => Some nil
      | (Var x, Var x') :: r
          => if x == x'
             then unify1 h' r
             else unify_subs x (Var x') r
             (*
               リストlの先頭が(Var x, Var x')の場合、
               x = x'なら、hを減らして、リストの残りrについてunify1を再帰的に実行する。
               x = x'でないなら、リストの残りrについてツリーの中の変数xを(Var x')で置き換える。
             *)
      | (Var x, t) :: r
          => unify_subs x t r
             (*
               リストlの先頭が(Var x, t)の場合、
               リストの残りrについてツリーの中の変数xをツリーtで置き換える。
             *)
      | (t, Var x) :: r
          => unify_subs x t r
             (*
               リストlの先頭が(t, Var x)の場合、
               リストの残りrについてツリーの中の変数xをツリーtで置き換える。
             *)
      | (Sym b, Sym b') :: r
          => if symbol_dec b b'
             then unify1 h' r
             else None
             (*
               リストlの先頭が(Sym b, Sym b')の場合、
                b = b'なら、hを減らして、リストの残りrについてunify1を再帰的に実行する。
                b = b'でないなら、Noneを返す。
             *)
      | (Fork t1 t2, Fork t1' t2') :: r
          => unify1 h' ((t1, t1') :: (t2, t2') :: r)
          (*
            リストlの先頭が(Fork t1 t2, Fork t1' t2')の場合、
            hを減らして、リストの残りrの前にリスト[:: (t1, t1'); (t2, t2')]をコンスしたリストについてunify1を再帰的に実行する。
          *)
      | _
          => None
          (*
            リストlが空リストでなくて先頭が上記以外の場合、Noneを返す。
          *)
      end
    else
      None.
      (*
        hが0の場合、Noneを返す。
      *)
  (*
    関数unify1は、
    第1引数が0ならNoneを返し、
    第1引数が1以上なら第2引数のリストl(list (tree * tree)型)の内容に応じた結果を返す様な関数。
    リストlの各要素のタプルに含まれるツリー同士を等しくするための(変数, ツリー)のタプルのリストを求めている？
  *)

End Unify1.

(* 等式の大きさの計算*)
Fixpoint size_tree (t : tree) : nat :=
  if t is Fork t1 t2
  then 1 + size_tree t1 + size_tree t2
  else 1.
(* 自己確認
  size_treeは、ツリーtのノードとリーフの合計数を返す関数らしい。
*)

Definition size_pairs (l : list (tree * tree)) :=
  sumn [seq size_tree p.1 + size_tree p.2 | p <- l].
(* 自己確認
  size_pairsは、リストlに含まれるタプルの要素であるツリーのノードとリーフの総数を求めて返る関数らしい。
*)

(* 代入したときだけ再帰*)
Fixpoint unify2 (h : nat) l :=
  if h is h'.+1
  then unify1 (unify2 h') (size_pairs l + 1) l
  else None.
(* 自己確認ここから *)
(*
  関数unify2は、
  第1引数hが0ならNoneを返し、
  第1引数hが1以上なら、hを1減らして、第2引数のリストlに対して関数unify1を適用する関数？
*)
Check unify2 : nat -> seq (tree * tree) -> option (seq (var * tree)).
(*
  h : nat
  l : seq (tree * tree)
*)
Check unify1 : (seq (tree * tree) -> option (seq (var * tree))) -> nat -> seq (tree * tree) -> option (seq (var * tree)).
(*
         (unify2 h') : (seq (tree * tree) -> option (seq (var * tree)))
  (size_pairs l + 1) : nat
                   l : seq (tree * tree)
*)
(* 自己確認ここまで *)

Fixpoint vars_pairs (l : list (tree * tree)) : list var :=
  match l with
  | nil => nil (* 集合を後部から作るようにする*)
  | (t1, t2) :: r => union (union (vars t1) (vars t2)) (vars_pairs r)
  end.
(* 自己確認ここから *)
(*
  関数vars_pairsは、引数のリストlの各要素に含まれるツリーの変数のリストを作成して返す関数らしい。
*)
(* 自己確認ここまで *)

(* 変数の数だけunify2 を繰り返す*)
Definition unify t1 t2 :=
  let l := [:: (t1, t2)]
  in unify2 (size (vars_pairs l) + 1) l.
(* 自己確認ここから *)
(*
  unifyは、第1引数t1と第2引数t2に含まれる変数の数だけ、タプル(t1, t2)に関数unify2を再帰的に適用する処理を表すらしい。
*)
(* 自己確認ここまで *)

(* 例*)
Eval compute in unify (Sym "a") (Var 1).
(*
  = Some [:: (1, Sym "a")] : option (seq (var * tree))

  変数1に(Sym "a")を対応させる模様。
*)
Eval compute in
  unify (Fork (Sym "a") (Var 0)) (Fork (Var 1) (Fork (Var 1) (Var 2))).
(*
  = Some [:: (1, Sym "a"); (0, Fork (Sym "a") (Var 2))] : option (seq (var * tree))

  Fork (Sym "a") (Var 0)
  Fork (Var 1)   (Fork (Var 1) (Var 2))
  の様に単一化させるらしいことから、
  変数1に(Sym "a")が割り当てられ、
  変数0に(Fork (Var 1) (Var 2))が割り当てられる模様。
  そして、変数1は(Sym "a")だから、変数0は(Fork (Sym "a") (Var 2))となる模様。
*)

(* 全ての等式の単一子*)
Definition unifies_pairs s (l : list (tree * tree)) :=
  forall t1 t2,
    (t1,t2) \in l ->
    unifies s t1 t2.
(* 自己確認
  ツリーt1,t2のタプル(t1,t2)がリストlに含まれていれば、
  sの元で、t1とt2を等しくできるという命題を表している？
*)

(* subs_list とFork が可換*)
Lemma subs_list_Fork s t1 t2 :
  subs_list s (Fork t1 t2) = Fork (subs_list s t1) (subs_list s t2).
Proof.
  elim: s t1 t2 => //.
  (* 追加ここから *)
  move=> x vl IH t1 t2 /=.
  by rewrite IH.
  (* 追加ここまで *)
Qed.

(* unifies_pairs の性質*)
Lemma unifies_pairs_same s t l :
  unifies_pairs s l -> unifies_pairs s ((t,t) :: l).
Proof.
  move=> H t1 t2; rewrite inE => /orP[].
  (* 追加ここから *)
  - (* (t1, t2) == (t, t) *)
    by move/eqP/pair_equal_spec => [-> ->].
  - (* (t1, t2) \in l *)
    by apply: H.
  (* 追加ここまで *)
Qed.

Lemma unifies_pairs_swap s t1 t2 l :
  unifies_pairs s ((t1, t2) :: l) ->
  unifies_pairs s ((t2, t1) :: l).
Proof.
  (* 追加ここから *)
  move=> H t1' t2'.
  rewrite in_cons => /orP [/eqP/pair_equal_spec [-> ->] | H'].
  - (* (t1', t2') == (t2, t1) *)
    rewrite /unifies.
    apply/eqP; rewrite eq_sym; apply/eqP.
    apply: H.
    rewrite in_cons.
    by apply/orP; left.
  - (* (t1', t2') \in l *)
    apply: H.
    rewrite in_cons.
    by apply/orP; right.
  (* 追加ここまで *)
Qed.

Lemma unify_subs_sound h v t l s : (* unify subs sound が最も重要な補題であるとのこと *)
  (forall s l, unify2 h l = Some s -> unifies_pairs s l) ->
  unify_subs (unify2 h) v t l = Some s ->
  unifies_pairs s ((Var v, t) :: l).
(*
  seq (tree * tree)型のリストl'にh回unify1を適用した結果、
  option (seq (var * tree))型のリストs'が得られて、
  任意のツリーt1',t2'について、タプル(t1',t2')が前記のリストl'に含まれるなら、
  得られたリストs'の元でt1'とt2'を等しくできるとする。
  そして、unify_subs (unify2 h) v t l の結果がsに等しいとする。
  すると、任意のツリーのタプル(t1,t2)がリスト(Var v, t) :: lに含まれるならsの元でt1とt2を等しくできる。
*)
Proof.
  rewrite /unify_subs.
  (*
    ゴールは
    (forall (s0 : seq (var * tree)) (l0 : seq (tree * tree)), unify2 h l0 = Some s0 -> unifies_pairs s0 l0) ->
    (if v \in vars t then None else may_cons v t (unify2 h [seq subs_pair v t i | i <- l])) = Some s ->
    unifies_pairs s ((Var v, t) :: l)
    となる。
  *)
  case Hocc: (v \in _) => // IH.
  (*
    (v \in vars t) = true or false で場合分け。
    (v \in vars t) = true の場合は try done で証明完了。
    (v \in vars t) = false の場合について
    まずフォーカスを IH という名前でコンテキストにポップ。
    ゴールは
    may_cons v t (unify2 h [seq subs_pair v t i | i <- l]) = Some s ->
    unifies_pairs s ((Var v, t) :: l)
    となる。
    (
      vars t は、t : tree に含まれる Var x の x の部分を集めたリストらしい。
      (v \in vars t) = false は、t : tree には Var v が含まれていないということ？
    )
  *)
  case Hun: (unify2 _ _) => [s'|] //= [] <-.
  (*
    (unify2 h [seq subs_pair v t i | i <- l]) = Some s' or None で場合分け。
    None の場合は try done で証明完了。
    Some s' の場合について
    Some ((v, t) :: s') = Some s から (v, t) :: s' = s を導いて
    ゴールの s を書き換えて、最終的にゴールは
    unifies_pairs ((v, t) :: s') ((Var v, t) :: l)
    となる。
    ゴールの意味は、
    forall t1 t2 : tree_eqType,
      (t1, t2) \in (Var v, t) :: l ->
      unifies ((v, t) :: s') t1 t2
    ↓
    任意のツリーt1,t2について、
    (t1,t2)がリスト(Var v,t)::lに含まれていれば、
    リスト(v,t)::s'の元でt1とt2を等しくすることができる。
    ということらしい。
    Check [seq subs_pair v t i | i <- l] : seq (tree * tree).
    となることより、
    Hun : unify2 h [seq subs_pair v t i | i <- l] = Some s'
    が意味するところは、
    seq (tree * tree)型のリストlから要素を1個ずつ取り出して、
    ツリーに含まれる変数vをツリーtで置き換えたseq (tree * tree)型のリストを求めて、
    求めたリストにh回関数unify1を適用した結果得られたoption (seq (var * tree))型のリストは
    Some s'であるということらしい。
  *)
  (* 追加ここから *)
  move: (Hocc) => /negbT/subs_same => Hocc'.
  move: (Hun).
  rewrite /subs_pair => Hun'.
  rewrite /unifies_pairs => t1 t2.
  rewrite in_cons => /orP.
  case.
  - (* (t1, t2) == (Var v, t) *)
    move/eqP.
    rewrite pair_equal_spec.
    case => [-> ->].
    rewrite /unifies /subs_list /= Hocc'.
    case Hvv : (v == v); first done.
    by rewrite eq_refl in Hvv.
  - (* (t1, t2) \in l *)
    move=> Ht1t2inl.
    rewrite /unifies /subs_list /=.
    apply: (IH s' [seq (subs v t p.1, subs v t p.2) | p <- l]); first done.
    move: (@map_f _ _ (fun p : (tree * tree) => (subs v t p.1, subs v t p.2)) l (t1, t2)).
    by apply.
  (* 追加ここまで *)
Qed.

(* unify2 の健全性*)
Theorem unify2_sound h s l :
  unify2 h l = Some s ->
  unifies_pairs s l.
(*
  リストlに対して関数unify1をh回適用した結果リストsが得られたなら、
  任意のツリーt1,t2について、
  (t1,t2)がlに含まれていればsの元でt1とt2を等しくすることができる。
*)
Proof.
  (*
    h : nat
    s : seq (var * tree)
    l : seq (tree * tree)
  *)
  elim: h s l => //= h IH s l.
  (*
    h に関する帰納法
    h = 0 の場合は try done により証明完了
    h > 0 の場合
    ゴールは
    unify1 (unify2 h) (size_pairs l + 1) l = Some s -> unifies_pairs s l
    となる
   *)
  move: (size_pairs l + 1) => h'.
  (*
    ゴールの (size_pairs l + 1) : nat を汎化してから
    コンテキストに h' : nat としてポップしている模様
  *)
  elim: h' l => //= h' IH' [] //.
  (*
    h' に関する帰納法
    h' = 0 の場合は try done により証明完了
    h' > 0 の場合
    l : seq (tree * tree) が空リストの場合と空リストでない場合とで場合分け
    空リストの場合は try done により証明完了
    l が空リストで無い場合、フォーカスの左辺は以下の様に場合分けされる模様
    (Var x, Var x0) :: r => if x == x0 then unify1 (unify2 h) h' r else unify_subs (unify2 h) x (Var x0) r
    (Var x, Sym _ as t0) :: r | (Var x, Fork _ _ as t0) :: r => unify_subs (unify2 h) x t0 r
    (Sym b as t, Var x) :: r => unify_subs (unify2 h) x t r
    (Sym b as t, Sym b') :: r => if is_left (symbol_dec b b') then unify1 (unify2 h) h' r else None
    (Sym b as t, Fork _ _) :: _ => None
    (Fork t1 t2 as t, Var x) :: r => unify_subs (unify2 h) x t r
    (Fork t1 t2 as t, Sym _) :: _ => None
    (Fork t1 t2 as t, Fork t1' t2') :: r => unify1 (unify2 h) h' [:: (t1, t1'), (t2, t2') & r]
  *)
  move=> [t1 t2] l.
  (* x, x0, r を t1, t2, l としてコンテキストにポップ *)
  destruct t1, t2 => //.
  (* t, t2 で場合分けし、自明の場合を try done で証明完了 *)
  (* VarVar *)
  - case: ifP.
      move/eqP => <- /IH'.
      by apply unifies_pairs_same.
    intros; by apply (unify_subs_sound h).
  (* VarSym *)
  - intros; by apply (unify_subs_sound h).
  (* 追加ここから *)
  (* VarFork *)
  - move=> H.
    apply: (unify_subs_sound h).
    move=> s0 l0.
    apply: IH.
    by apply: H.
  (* SymVar *)
  - move=> H.
    apply/unifies_pairs_swap/(unify_subs_sound h).
    move=> s1 l0.
    apply: IH.
    by apply: H.
  (* SymSym *)
  - case (symbol_dec s0 s1) => Hs0s1 //= H. (* s0 <> s1 の場合は try done により証明完了 *)
    rewrite Hs0s1.
    by apply/unifies_pairs_same/IH'/H.
  (* ForkVar *)
  - move=> H.
    apply/unifies_pairs_swap/(unify_subs_sound h).
    move=> s0 l0.
    apply: IH.
    by apply: H.
  (* ForkFork *)
  - move=> H.
    rewrite /unifies_pairs => t1 t2.
    rewrite in_cons => /orP [/eqP/pair_equal_spec [-> ->] | H'].
    + (* (t1, t2) == (Fork t1_1 t1_2, Fork t2_1 t2_2) *)
      rewrite /unifies.
      rewrite !subs_list_Fork.
      move: ((IH' [:: (t1_1, t2_1), (t1_2, t2_2) & l]) H) => H'.
      have -> : subs_list s t1_1 = subs_list s t2_1.
        apply: H'.
        rewrite in_cons.
        by apply/orP; left.
      have -> : subs_list s t1_2 = subs_list s t2_2.
        apply: H'.
        rewrite in_cons.
        apply/orP; right; rewrite in_cons.
        by apply/orP; left.
      by [].
    + (* (t1, t2) \in l *)
      apply: (IH' [:: (t1_1, t2_1), (t1_2, t2_2) & l]); first done.
      rewrite !in_cons.
      rewrite Bool.orb_assoc.
      apply/orP/orP/orP.
      by right.
  (* 追加ここまで *)
Qed.

(* 単一化の健全性*)
Corollary soundness t1 t2 s :
  unify t1 t2 = Some s ->
  unifies s t1 t2.
(*
  第1引数t1と第2引数t2に含まれる変数の数だけ、タプル(t1, t2)に関数unify2を再帰的に適用した結果、リストsが得られたなら、
  sの元でt1とt2を等しくすることができる。
  (「unify t1 t2」が t1, t2 に関する単一化を表していて、
   「unifies s t1 t2」が単一化を行った結果得られた s が t1, t2 の単一子であることを表している？
   単一化の結果、None でない何某かのリスト s が得られたら、それは単一子になっているということ？)
*)
Proof.
  (* 追加ここから *)
  move=> H.
  apply: (@unify2_sound (size (vars_pairs [:: (t1, t2)]) + 1) s [:: (t1, t2)]).
  - by rewrite /unify in H.
  - by rewrite mem_seq1.
  (* 追加ここまで *)
Qed.

(* 完全性*)

(* s が s' より一般的な単一子である*)
Definition moregen s s' :=
  exists s2,
    forall t,
      subs_list s' t = subs_list s2 (subs_list s t).
(*
  moregenは、
  任意の(変数とツリーのタプルの)リストs,s'について、
  ある(変数とツリーのタプルの)リストs2が存在して、
  任意のツリーtについて、
  sの元でtの変数を置き換えてできたツリーの変数をs2に従って置き換えると、
  s'のもとでtの変数を置き換えてできたツリーと等しくすることができる。
  という命題を表している模様。
*)

(* 自己確認ここから *)
Eval compute in unify (Fork (Sym "a") (Sym "b")) (Fork (Var 1) (Var 2)).
(* = Some [:: (1, Sym "a"); (2, Sym "b")] : option (seq (var * tree)) *)

Eval compute in subs_list [:: (1, Sym "a"); (2, Sym "b")] (Fork (Var 1) (Var 2)).
(* = Fork (Sym "a") (Sym "b") : tree *)

Eval compute in subs_list [:: (1, Sym "a"); (2, Sym "b"); (3, Sym "c")] (Fork (Var 1) (Var 2)).
(* = Fork (Sym "a") (Sym "b") : tree *)

Eval compute in subs_list [:: (1, Sym "a"); (2, Sym "b"); (3, Sym "c")] (Fork (Sym "a") (Sym "b")).
(* = Fork (Sym "a") (Sym "b") : tree *)

Goal
  unifies [:: (1, Sym "a"); (2, Sym "b"); (3, Sym "c")] (Fork (Sym "a") (Sym "b")) (Fork (Var 1) (Var 2)).
Proof.
  by [].
Qed.

Goal
  unify (Fork (Sym "a") (Sym "b")) (Fork (Var 1) (Var 2)) = Some [:: (1, Sym "a"); (2, Sym "b")].
Proof.
  by [].
Qed.

Eval compute in (vars (Fork (Sym "a") (Sym "b"))).
(* = [::] : seq var *)

Eval compute in (vars (Fork (Var 1) (Var 2))).
(* = [:: 1; 2] : seq var *)

Eval compute in (union (vars (Fork (Sym "a") (Sym "b"))) (vars (Fork (Var 1) (Var 2)))).
(* = [:: 1; 2] : seq var *)

Eval compute in [seq p <- [:: (1, Sym "a"); (2, Sym "b"); (3, Sym "c")]
                 | p.1 \in (union (vars (Fork (Sym "a") (Sym "b"))) (vars (Fork (Var 1) (Var 2))))].
(* = [:: (1, Sym "a"); (2, Sym "b")] : seq (nat_eqType * tree) *)

Goal
  unify (Fork (Sym "a") (Sym "b")) (Fork (Var 1) (Var 2))
  = Some [seq p <- [:: (1, Sym "a"); (2, Sym "b"); (3, Sym "c")]
          | p.1 \in (union (vars (Fork (Sym "a") (Sym "b"))) (vars (Fork (Var 1) (Var 2))))].
Proof.
  by [].
Qed.

Eval compute in [seq p <- [:: (1, Sym "a"); (2, Sym "b"); (3, Sym "c")]
                 | p.1 \notin (union (vars (Fork (Sym "a") (Sym "b"))) (vars (Fork (Var 1) (Var 2))))].
(* = [:: (3, Sym "c")] : seq (nat_eqType * tree) *)

Goal
  forall t,
    subs_list [:: (1, Sym "a"); (2, Sym "b"); (3, Sym "c")] t
    = subs_list [:: (3, Sym "c")] (subs_list [:: (1, Sym "a"); (2, Sym "b")] t).
Proof.
  by [].
Qed.
(* 自己確認ここまで *)

(* 単一化の完全性*)
Corollary unify_complete s t1 t2 :
  unifies s t1 t2 ->
  exists s1,
    unify t1 t2 = Some s1 /\ moregen s1 s.
(*
  sの元でt1とt2を等しいなら、
  s1が存在して、
  t1とt2に含まれる変数の数だけ(t1, t2)にunify2を再帰的に適用した結果得られたリストはs1に等しく、
  exists s2,
    forall t,
      subs_list s t = subs_list s2 (subs_list s1 t)
  が成り立つ。
  (リスト s がツリー t1, t2 の単一子であるなら、
   ツリー t1, t2 の単一化の結果、None でない何某かのリスト s1 が得られて、
   s1 に対応する s2 を選ぶことで、任意のツリー t について
   subs_list s t = subs_list s2 (subs_list s1 t)
   を成立させることができる、ということ？
   s が単一子であるならば、単一化により得られた s1 を元に、s1 に対応する s2 を選ぶことで、
   s と同じ働きをする単一子を構成することができるということ？
   単一子は、単一化により作り出すことができるということ？
   単一化により作り出した単一子が単一子の全てであり、単一化により作り出せない単一子は存在しないということ？)
*)
Proof.
  (* 追加ここから *)
  (*
    unify t1 t2 の結果得られる None でないリスト s1 には、
    t1, t2 に含まれる(全てとは限らない)変数と、
    その変数に対応する値(ツリー)のタプルが含まれるはず。
    そして、リスト s2 として、s1 に含まれない変数と対応する値(ツリー)のタプルからなるリストを選べば、
    任意のツリー t に対して s と同じ様に単一化を行えるはず。
    具体例での確認から、上記の様に予想して証明に着手。
  *)

  exists [seq p <- s | p.1 \in union (vars t1) (vars t2)].
  split.
  - rewrite /unify.
    rewrite addn1.
    rewrite /=.
    rewrite addn1.
    rewrite /=.
    admit. (* ここで手詰まり *)
  - rewrite /moregen.
    exists [seq p <- s | p.1 \notin union (vars t1) (vars t2)].
    elim s => //=.
    move=> a l IH t.
    admit. (* ここで手詰まり *)
  (* 証明完了に至っていない。補題 uniq_union の出番も見つかっていない。 *)

  (* 追加ここまで *)
Admitted.


(* -*- mode: coq; mode: visual-line -*- *)

(** * Factorizations and factorization systems. *)

Require Import HoTT.Basics HoTT.Types.
Require Import HProp FunextVarieties UnivalenceImpliesFunext Extensions PathAny.
Require Import HoTT.Tactics.
Local Open Scope path_scope.

(** ** Factorizations *)

Section Factorization.
  Universes ctxi.
  (** It's important that these are all declared with a single [Context] command, so that the marker [@{i}] refers to the same universe level in all of them. *)
  Context {class1 class2 : forall (X Y : Type@{ctxi}), (X -> Y) -> Type@{ctxi}}
          `{forall (X Y : Type@{ctxi}) (g:X->Y), IsHProp (class1 _ _ g)}
          `{forall (X Y : Type@{ctxi}) (g:X->Y), IsHProp (class2 _ _ g)}
          {A B : Type@{ctxi}} {f : A -> B}.

  (** A factorization of [f] into a first factor lying in [class1] and a second factor lying in [class2]. *)
  Record Factorization :=
    { intermediate : Type ;
      factor1 : A -> intermediate ;
      factor2 : intermediate -> B ;
      fact_factors : factor2 o factor1 == f ;
      inclass1 : class1 _ _ factor1 ;
      inclass2 : class2 _ _ factor2
    }.

  Lemma issig_Factorization :
    { I : Type & { g : A -> I & { h : I -> B & { p : h o g == f &
      { gin1 : class1 _ _ g & class2 _ _ h }}}}}
      <~> Factorization.
  Proof.
    issig.
  Defined.

  (** A path between factorizations is equivalent to a structure of the following sort. *)
  Record PathFactorization {fact fact' : Factorization} :=
    { path_intermediate : intermediate fact <~> intermediate fact' ;
      path_factor1 : path_intermediate o factor1 fact == factor1 fact' ;
      path_factor2 : factor2 fact == factor2 fact' o path_intermediate ;
      path_fact_factors : forall a, path_factor2 (factor1 fact a)
                          @ ap (factor2 fact') (path_factor1 a)
                          @ fact_factors fact' a
                          = fact_factors fact a
    }.
  Arguments PathFactorization fact fact' : clear implicits.

  Lemma issig_PathFactorization (fact fact' : Factorization) :
    { path_intermediate : intermediate fact <~> intermediate fact' &
    { path_factor1 : path_intermediate o factor1 fact == factor1 fact' &
    { path_factor2 : factor2 fact == factor2 fact' o path_intermediate &
       forall a, path_factor2 (factor1 fact a)
                              @ ap (factor2 fact') (path_factor1 a)
                              @ fact_factors fact' a
                 = fact_factors fact a }}}
      <~> PathFactorization fact fact'.
  Proof.
    issig.
  Defined.

  Definition equiv_path_factorization `{Univalence}
             (fact fact' : Factorization)
    : PathFactorization fact fact' <~> fact = fact'.
  Proof.
    refine (_ oE (issig_PathFactorization fact fact')^-1).
    revert fact fact'; apply (equiv_path_issig_contr issig_Factorization).
    { intros [I [f1 [f2 [ff [oc1 oc2]]]]].
      exists (equiv_idmap I); cbn.
      exists (fun x:A => 1%path); cbn.
      exists (fun x:I => 1%path); cbn.
      intros; apply concat_1p. }
    intros [I [f1 [f2 [ff [oc1 oc2]]]]].
    contr_sigsig I (equiv_idmap I); cbn.
    contr_sigsig f1 (fun x:A => idpath (f1 x)); cbn.
    contr_sigsig f2 (fun x:I => idpath (f2 x)); cbn.
    refine (contr_equiv' {ff' : f2 o f1 == f & ff == ff'} _).
    symmetry; srefine (equiv_functor_sigma' (equiv_sigma_contr _) _).
    { intros h; cbn.
      srefine (@trunc_sigma _ _ _ _ _); [ | intros a];
        apply contr_inhabited_hprop; try exact _; assumption. }
    intros [ff' [oc1' oc2']]; cbn.
    refine (equiv_functor_forall' (equiv_idmap _) _); intros a.
    refine (equiv_path_inverse _ _ oE _).
    apply equiv_concat_l; symmetry; apply concat_1p.
  Defined.

  Definition path_factorization `{Univalence} (fact fact' : Factorization)
    : PathFactorization fact fact' -> fact = fact'
    := equiv_path_factorization fact fact'.

End Factorization.

Arguments Factorization class1 class2 {A B} f.
Arguments PathFactorization {class1 class2 A B f} fact fact'.

(* This enables us to talk about "the image of a map" as a factorization but also as the intermediate object appearing in it, as is common in informal mathematics. *)
Coercion intermediate : Factorization >-> Sortclass.

(** ** Factorization Systems *)

(** A ("unique" or "orthogonal") factorization system consists of a couple of classes of maps, closed under composition, such that every map admits a unique factorization. *)
Record FactorizationSystem@{i j k} :=
  { class1 : forall {X Y : Type@{i}}, (X -> Y) -> Type@{j} ;
    ishprop_class1 : forall {X Y : Type@{i}} (g:X->Y), IsHProp (class1 g) ;
    class1_isequiv : forall {X Y : Type@{i}} (g:X->Y) {geq:IsEquiv g}, class1 g ;
    class1_compose : forall {X Y Z : Type@{i}} (g:X->Y) (h:Y->Z),
                       class1 g -> class1 h -> class1 (h o g) ;
    class2 : forall {X Y : Type@{i}}, (X -> Y) -> Type@{k} ;
    ishprop_class2 : forall {X Y : Type@{i}} (g:X->Y), IsHProp (class2 g) ;
    class2_isequiv : forall {X Y : Type@{i}} (g:X->Y) {geq:IsEquiv g}, class2 g ;
    class2_compose : forall {X Y Z : Type@{i}} (g:X->Y) (h:Y->Z),
                       class2 g -> class2 h -> class2 (h o g) ;
    (** Morally, the uniqueness of factorizations says that [Factorization class1 class2 f] is contractible.  However, in practice we always *prove* that by way of [path_factorization], and we frequently want to *use* the components of a [PathFactorization] as well.  Thus, as data we store the canonical factorization and a [PathFactorization] between any two such, and prove in a moment that this implies contractibility of the space of factorizations. *)
    factor : forall {X Y : Type@{i}} (f:X->Y), Factorization@{i i} (@class1) (@class2) f ;
    path_factor : forall {X Y : Type@{i}} (f:X->Y)
                         (fact : Factorization@{i i} (@class1) (@class2) f)
                         (fact' : Factorization@{i i} (@class1) (@class2) f),
                    PathFactorization@{i i i} fact fact'
  }.

Global Existing Instances ishprop_class1 ishprop_class2.

Section FactSys.

  Context `{Univalence} (factsys : FactorizationSystem).

  Definition Build_Factorization' {X Y}
    := @Build_Factorization (@class1 factsys) (@class2 factsys) X Y.

  Definition Build_PathFactorization' {X Y}
    := @Build_PathFactorization (@class1 factsys) (@class2 factsys) X Y.

  (** The type of factorizations is, as promised, contractible. *)
  Theorem contr_factor {X Y} (f : X -> Y)
  : Contr (Factorization (@class1 factsys) (@class2 factsys) f).
  Proof.
    apply contr_inhabited_hprop.
    - apply hprop_allpath.
      intros fact fact'.
      apply path_factorization; try exact _.
      apply path_factor.
    - apply factor.
  Defined.

  (** It follows that the left class is right-cancellable and the right class is left-cancellable. *)
  Definition cancelR_class1 {X Y Z} (f : X -> Y) (g : Y -> Z)
  : class1 factsys f -> class1 factsys (g o f) -> class1 factsys g.
  Proof.
    intros c1f c1gf.
    destruct (factor factsys g) as [I g1 g2 gf c1g1 c2g2].
    pose (fact  := Build_Factorization' (g o f) Z (g o f) (idmap)
                     (fun x => 1) c1gf (class2_isequiv factsys idmap)).
    pose (fact' := Build_Factorization' (g o f) I (g1 o f) g2
                     (fun x => gf (f x))
                     (class1_compose factsys f g1 c1f c1g1) c2g2).
    destruct (path_factor factsys (g o f) fact fact')
             as [q q1 q2 qf]; simpl in *.
    refine (transport (class1 factsys) (path_arrow _ _ gf) _).
    refine (class1_compose factsys g1 g2 c1g1 _).
    refine (transport (class1 factsys) (path_arrow q^-1 g2 _)
                      (class1_isequiv factsys q^-1)).
    unfold pointwise_paths; equiv_intro q x.
    exact (eissect q x @ q2 x).
  Defined.

  Definition cancelL_class2 {X Y Z} (f : X -> Y) (g : Y -> Z)
  : class2 factsys g -> class2 factsys (g o f) -> class2 factsys f.
  Proof.
    intros c2g c2gf.
    destruct (factor factsys f) as [I f1 f2 ff c1f1 c2f2].
    pose (fact  := Build_Factorization' (g o f) X (idmap) (g o f)
                     (fun x => 1) (class1_isequiv factsys idmap) c2gf).
    pose (fact' := Build_Factorization' (g o f) I f1 (g o f2)
                     (fun x => ap g (ff x))
                     c1f1 (class2_compose factsys f2 g c2f2 c2g)).
    destruct (path_factor factsys (g o f) fact fact')
             as [q q1 q2 qf]; simpl in *.
    refine (transport (class2 factsys) (path_arrow _ _ ff) _).
    refine (class2_compose factsys f1 f2 _ c2f2).
    exact (transport (class2 factsys) (path_arrow q f1 q1)
                     (class2_isequiv factsys q)).
  Defined.

  (** The two classes of maps are automatically orthogonal, i.e. any commutative square from a [class1] map to a [class2] map has a unique diagonal filler.  For now, we only bother to define the lift; in principle we ought to show that the type of lifts is contractible. *)
  Universe ctxi.
  Context {A B X Y : Type@{ctxi}}
          (i : A -> B) (c1i : class1 factsys i)
          (p : X -> Y) (c2p : class2 factsys p)
          (f : A -> X) (g : B -> Y) (h : p o f == g o i).

  (** First we factor [f] *)
  Let C  : Type         := intermediate (factor factsys f).
  Let f1 : A -> C       := factor1      (factor factsys f).
  Let f2 : C -> X       := factor2      (factor factsys f).
  Let ff : f2 o f1 == f := fact_factors (factor factsys f).

  (** and [g] *)
  Let D  : Type         := intermediate (factor factsys g).
  Let g1 : B -> D       := factor1      (factor factsys g).
  Let g2 : D -> Y       := factor2      (factor factsys g).
  Let gf : g2 o g1 == g := fact_factors (factor factsys g).

  (** Now we observe that [p o f2] and [f1], and [g2] and [g1 o i], are both factorizations of the common diagonal of the commutative square (for which we use [p o f], but we could equally well use [g o i]. *)
  Let fact  : Factorization (@class1 factsys) (@class2 factsys) (p o f)
            := Build_Factorization' (p o f) C f1 (p o f2)
                 (fun a => ap p (ff a))
                 (inclass1 (factor factsys f))
                 (class2_compose factsys f2 p
                                 (inclass2 (factor factsys f))
                                 c2p).
  Let fact' : Factorization (@class1 factsys) (@class2 factsys) (p o f)
            := Build_Factorization' (p o f) D (g1 o i) g2
                 (fun a => gf (i a) @ (h a)^)
                 (class1_compose factsys i g1 c1i
                                 (inclass1 (factor factsys g)))
                 (inclass2 (factor factsys g)).

  (** Therefore, by the uniqueness of factorizations, we have an equivalence [q] relating them. *)
  Let q  : C <~> D          := path_intermediate
                                 (path_factor factsys (p o f) fact fact').
  Let q1 : q o f1 == g1 o i := path_factor1
                                 (path_factor factsys (p o f) fact fact').
  Let q2 : p o f2 == g2 o q := path_factor2
                                 (path_factor factsys (p o f) fact fact').

  (** Using this, we can define the lift. *)
  Definition lift_factsys : B -> X
    := f2 o q^-1 o g1.

  (** And the commutative triangles making it a lift *)
  Definition lift_factsys_tri1 : lift_factsys o i == f.
  Proof.
    intros x.
    refine (ap (f2 o q^-1) (q1 x)^ @ _).
    transitivity (f2 (f1 x)).
    + apply ap, eissect.
    + apply ff.
  Defined.

  Definition lift_factsys_tri2 : p o lift_factsys == g.
  Proof.
    intros x.
    refine (q2 _ @ _).
    transitivity (g2 (g1 x)).
    + apply ap, eisretr.
    + apply gf.
  Defined.

  (** And finally prove that these two triangles compose to the given commutative square. *)
  Definition lift_factsys_square (x : A)
  : ap p (lift_factsys_tri1 x)^ @ lift_factsys_tri2 (i x) = h x.
  Proof.
    unfold lift_factsys_tri1, lift_factsys_tri2.
    Open Scope long_path_scope.
    (* First we use the one aspect of the uniqueness of factorizations that we haven't mentioned yet. *)
    pose (r := path_fact_factors (path_factor factsys (p o f) fact fact') x
            : q2 (f1 x) @ ap g2 (q1 x) @ (gf (i x) @ (h x)^) = ap p (ff x)).
    rewrite concat_p_pp in r.
    apply moveL_pM, moveR_Vp in r.
    refine (_ @ r); clear r.
    (* Now we can cancel some whiskered paths on both sides. *)
    repeat rewrite inv_pp; repeat rewrite ap_pp; rewrite ap_V.
    repeat rewrite concat_pp_p; apply whiskerL.
    repeat rewrite concat_p_pp; apply whiskerR.
    (* Next we set up for a naturality. *)
    rewrite (ap_compose q^-1 f2), <- ap_pp, <- inv_pp.
    (* The next line appears to do nothing, but in fact it is necessary for the subsequent [rewrite] to succeed, because [lift_factsys] appears in the invisible implicit point-arguments of [paths].  One way to discover issues of that sort is to turn on printing of all implicit argumnets with [Set Printing All]; another is to use [Set Debug Tactic Unification] and inspect the output to see what [rewrite] is trying and failing to unify. *)
    unfold lift_factsys.
    rewrite <- ap_pp.
    rewrite <- ap_V, <- ap_compose.
    rewrite (concat_Ap q2).
    (* Now we can cancel another path *)
    rewrite concat_pp_p; apply whiskerL.
    (* And set up for an application of [ap]. *)
    rewrite ap_compose.
    rewrite <- ap_pp.
    apply ap.
    (* Now we apply the triangle identity [eisadj]. *)
    rewrite inv_pp, ap_pp, ap_V.
    rewrite <- eisadj.
    (* Finally, we rearrange and it becomes a naturality square. *)
    rewrite concat_pp_p; apply moveR_Vp.
    rewrite <- ap_V, inv_V, <- ap_compose.
    exact (concat_A1p (eisretr q) (q1 x)).
    Close Scope long_path_scope.
  Qed.

End FactSys.

Section FactsysExtensions.
  Context {factsys : FactorizationSystem} {ua : Univalence}.

  (** We can deduce the lifting property in terms of extensions fairly easily from the version in terms of commutative squares. *)
  Definition extension_factsys {A B : Type}
             (f : A -> B) {c1f : class1 factsys f}
             (P : B -> Type) (c2P : class2 factsys (@pr1 B P))
             (d : forall a:A, P (f a))
  : ExtensionAlong f P d.
  Proof.
    pose (e := lift_factsys factsys f c1f pr1 c2P
                            (fun a => (f a ; d a)) idmap
                            (fun a => 1)).
    pose (e2 := lift_factsys_tri2 factsys f c1f pr1 c2P
                            (fun a => (f a ; d a)) idmap
                            (fun a => 1)).
    exists (fun a => (e2 a) # (e a).2).
    intros a.
    pose (e1 := lift_factsys_tri1 factsys f c1f pr1 c2P
                            (fun a => (f a ; d a)) idmap
                            (fun a => 1) a
                : e (f a) = (f a ; d a)).
    pose (e3 := moveL_M1 _ _ (((ap_V _ _)^ @@ 1)
                @ lift_factsys_square factsys f c1f pr1 c2P
                            (fun a => (f a ; d a)) idmap
                            (fun a => 1) a)
                : e2 (f a) = pr1_path e1).
    refine (ap (fun p => transport P p (e (f a)).2) e3 @ _).
    exact (pr2_path e1).
  Defined.

End FactsysExtensions.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Exercise_1.

Coq < Goal forall j f m p:Prop, (((j \/ f) \/ m) /\ ((j \/ m) -> ~p) /\ (~f)) -> ~(f \/ p).
1 subgoal

  ============================
   forall j f m p : Prop,
   ((j \/ f) \/ m) /\ (j \/ m -> ~ p) /\ ~ f -> ~ (f \/ p)

Unnamed_thm < intros.
1 subgoal

  j : Prop
  f : Prop
  m : Prop
  p : Prop
  H : ((j \/ f) \/ m) /\ (j \/ m -> ~ p) /\ ~ f
  ============================
   ~ (f \/ p)

Unnamed_thm < elim H.
1 subgoal

  j : Prop
  f : Prop
  m : Prop
  p : Prop
  H : ((j \/ f) \/ m) /\ (j \/ m -> ~ p) /\ ~ f
  ============================
   (j \/ f) \/ m -> (j \/ m -> ~ p) /\ ~ f -> ~ (f \/ p)

Unnamed_thm < intro.
1 subgoal

  j : Prop
  f : Prop
  m : Prop
  p : Prop
  H : ((j \/ f) \/ m) /\ (j \/ m -> ~ p) /\ ~ f
  H0 : (j \/ f) \/ m
  ============================
   (j \/ m -> ~ p) /\ ~ f -> ~ (f \/ p)

Unnamed_thm < intro.
1 subgoal

  j : Prop
  f : Prop
  m : Prop
  p : Prop
  H : ((j \/ f) \/ m) /\ (j \/ m -> ~ p) /\ ~ f
  H0 : (j \/ f) \/ m
  H1 : (j \/ m -> ~ p) /\ ~ f
  ============================
   ~ (f \/ p)

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <

*)

Section Exercise_1.
Goal forall j f m p:Prop, (((j \/ f) \/ m) /\ ((j \/ m) -> ~p) /\ (~f)) -> ~(f \/ p).
intros.
elim H.
intro.
intro.
firstorder.
Qed.


Require Export prosa.behavior.all.

(** This file defines simple allocation substitutions and a swapping operation
    as used for instance in the classic EDF optimality proof. *)

(** We begin by defining the notion of a schedule with a "tweaked" (i.e.,
    overridden) allocation. *)
Section ReplaceAt.
  (** For any given type of jobs... *)
  Context {Job : JobType}.
  (** ... any given type of processor states, ... *)
  Context {PState: eqType}.
  Context `{ProcessorState Job PState}.

  (** ...consider any given reference schedule. *)
  Variable original_sched: schedule PState.

  (** Suppose we are given a specific time [t'] ... *)
  Variable t': instant.

  (** ...and a replacement state [new_state]. *)
  Variable new_state: PState.

  (** Then the schedule with replacement is simply one that returns the given
     [new_state] at [t'], and the original allocation at all other times. *)
  Definition replace_at (t : instant) :=
    if t' == t then new_state else (original_sched t).

End ReplaceAt.

(** Based on [replace_at], we define the notion of a schedule with swapped
    allocations. *)
Section Swapped.
  (** For any given type of jobs... *)
  Context {Job : JobType}.
  (** ... any given type of processor states, ... *)
  Context {PState: eqType}.
  Context `{ProcessorState Job PState}.

  (** ...consider any given reference schedule. *)
  Variable original_sched: schedule PState.

  (** Given two specific times [t1] and [t2]... *)
  Variable t1 t2: instant.

  (** ...we define the notion of a schedule in which the two allocations at [t1]
     and [t2] have been swapped. *)
  Definition swapped : schedule PState :=
    let s1 := original_sched t1 in
    let s2 := original_sched t2 in
    let replaced_s1 := replace_at original_sched t1 s2 in
    replace_at replaced_s1 t2 s1.

End Swapped.


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

(*i $Id: Sqrt_reg.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Rbase.
Require Import Rfunctions.
Require Import Ranalysis1.
Require Import R_sqrt.
Open Local Scope R_scope.

(**********)
Lemma sqrt_var_maj :
  forall h:R, Rabs h <= 1 -> Rabs (sqrt (1 + h) - 1) <= Rabs h.
Proof.
  intros; cut (0 <= 1 + h).
  intro; apply Rle_trans with (Rabs (sqrt (Rsqr (1 + h)) - 1)).
  case (total_order_T h 0); intro.
  elim s; intro.
  repeat rewrite Rabs_left.
  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1)).
  do 2 rewrite Ropp_plus_distr; rewrite Ropp_involutive;
    apply Rplus_le_compat_l.
  apply Ropp_le_contravar; apply sqrt_le_1.
  apply Rle_0_sqr.
  apply H0.
  pattern (1 + h) at 2 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
    apply Rmult_le_compat_l.
  apply H0.
  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
    assumption.
  apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
    unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
      rewrite Rplus_0_r.
  pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
  apply Rle_0_sqr.
  left; apply Rlt_0_1.
  pattern 1 at 2 in |- *; rewrite <- Rsqr_1; apply Rsqr_incrst_1.
  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
    assumption.
  apply H0.
  left; apply Rlt_0_1.
  apply Rplus_lt_reg_r with 1; rewrite Rplus_0_r; rewrite Rplus_comm;
    unfold Rminus in |- *; rewrite Rplus_assoc; rewrite Rplus_opp_l;
      rewrite Rplus_0_r.
  pattern 1 at 2 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
  apply H0.
  left; apply Rlt_0_1.
  pattern 1 at 2 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
    assumption.
  rewrite b; rewrite Rplus_0_r; rewrite Rsqr_1; rewrite sqrt_1; right;
    reflexivity.
  repeat rewrite Rabs_right.
  unfold Rminus in |- *; do 2 rewrite <- (Rplus_comm (-1));
    apply Rplus_le_compat_l.
  apply sqrt_le_1.
  apply H0.
  apply Rle_0_sqr.
  pattern (1 + h) at 1 in |- *; rewrite <- Rmult_1_r; unfold Rsqr in |- *;
    apply Rmult_le_compat_l.
  apply H0.
  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
    assumption.
  apply Rle_ge; apply Rplus_le_reg_l with 1.
  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
  pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_le_1.
  left; apply Rlt_0_1.
  apply Rle_0_sqr.
  pattern 1 at 1 in |- *; rewrite <- Rsqr_1; apply Rsqr_incr_1.
  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left;
    assumption.
  left; apply Rlt_0_1.
  apply H0.
  apply Rle_ge; left; apply Rplus_lt_reg_r with 1.
  rewrite Rplus_0_r; rewrite Rplus_comm; unfold Rminus in |- *;
    rewrite Rplus_assoc; rewrite Rplus_opp_l; rewrite Rplus_0_r.
  pattern 1 at 1 in |- *; rewrite <- sqrt_1; apply sqrt_lt_1.
  left; apply Rlt_0_1.
  apply H0.
  pattern 1 at 1 in |- *; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l;
    assumption.
  rewrite sqrt_Rsqr.
  replace (1 + h - 1) with h; [ right; reflexivity | ring ].
  apply H0.
  case (total_order_T h 0); intro.
  elim s; intro.
  rewrite (Rabs_left h a) in H.
  apply Rplus_le_reg_l with (- h).
  rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
    rewrite Rplus_opp_r; rewrite Rplus_0_r; exact H.
  left; rewrite b; rewrite Rplus_0_r; apply Rlt_0_1.
  left; apply Rplus_lt_0_compat.
  apply Rlt_0_1.
  apply r.
Qed.

(** sqrt is continuous in 1 *)
Lemma sqrt_continuity_pt_R1 : continuity_pt sqrt 1.
Proof.
  unfold continuity_pt in |- *; unfold continue_in in |- *;
    unfold limit1_in in |- *; unfold limit_in in |- *;
      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
        intros.
  set (alpha := Rmin eps 1).
  exists alpha; intros.
  split.
  unfold alpha in |- *; unfold Rmin in |- *; case (Rle_dec eps 1); intro.
  assumption.
  apply Rlt_0_1.
  intros; elim H0; intros.
  rewrite sqrt_1; replace x with (1 + (x - 1)); [ idtac | ring ];
    apply Rle_lt_trans with (Rabs (x - 1)).
  apply sqrt_var_maj.
  apply Rle_trans with alpha.
  left; apply H2.
  unfold alpha in |- *; apply Rmin_r.
  apply Rlt_le_trans with alpha;
    [ apply H2 | unfold alpha in |- *; apply Rmin_l ].
Qed.

(** sqrt is continuous forall x>0 *)
Lemma sqrt_continuity_pt : forall x:R, 0 < x -> continuity_pt sqrt x.
Proof.
  intros; generalize sqrt_continuity_pt_R1.
  unfold continuity_pt in |- *; unfold continue_in in |- *;
    unfold limit1_in in |- *; unfold limit_in in |- *;
      unfold dist in |- *; simpl in |- *; unfold R_dist in |- *;
        intros.
  cut (0 < eps / sqrt x).
  intro; elim (H0 _ H2); intros alp_1 H3.
  elim H3; intros.
  set (alpha := alp_1 * x).
  exists (Rmin alpha x); intros.
  split.
  change (0 < Rmin alpha x) in |- *; unfold Rmin in |- *;
    case (Rle_dec alpha x); intro.
  unfold alpha in |- *; apply Rmult_lt_0_compat; assumption.
  apply H.
  intros; replace x0 with (x + (x0 - x)); [ idtac | ring ];
    replace (sqrt (x + (x0 - x)) - sqrt x) with
    (sqrt x * (sqrt (1 + (x0 - x) / x) - sqrt 1)).
  rewrite Rabs_mult; rewrite (Rabs_right (sqrt x)).
  apply Rmult_lt_reg_l with (/ sqrt x).
  apply Rinv_0_lt_compat; apply sqrt_lt_R0; assumption.
  rewrite <- Rmult_assoc; rewrite <- Rinv_l_sym.
  rewrite Rmult_1_l; rewrite Rmult_comm.
  unfold Rdiv in H5.
  case (Req_dec x x0); intro.
  rewrite H7; unfold Rminus, Rdiv in |- *; rewrite Rplus_opp_r;
    rewrite Rmult_0_l; rewrite Rplus_0_r; rewrite Rplus_opp_r;
      rewrite Rabs_R0.
  apply Rmult_lt_0_compat.
  assumption.
  apply Rinv_0_lt_compat; rewrite <- H7; apply sqrt_lt_R0; assumption.
  apply H5.
  split.
  unfold D_x, no_cond in |- *.
  split.
  trivial.
  red in |- *; intro.
  cut ((x0 - x) * / x = 0).
  intro.
  elim (Rmult_integral _ _ H9); intro.
  elim H7.
  apply (Rminus_diag_uniq_sym _ _ H10).
  assert (H11 := Rmult_eq_0_compat_r _ x H10).
  rewrite <- Rinv_l_sym in H11.
  elim R1_neq_R0; exact H11.
  red in |- *; intro; rewrite H12 in H; elim (Rlt_irrefl _ H).
  symmetry  in |- *; apply Rplus_eq_reg_l with 1; rewrite Rplus_0_r;
    unfold Rdiv in H8; exact H8.
  unfold Rminus in |- *; rewrite Rplus_comm; rewrite <- Rplus_assoc;
    rewrite Rplus_opp_l; rewrite Rplus_0_l; elim H6; intros.
  unfold Rdiv in |- *; rewrite Rabs_mult.
  rewrite Rabs_Rinv.
  rewrite (Rabs_right x).
  rewrite Rmult_comm; apply Rmult_lt_reg_l with x.
  apply H.
  rewrite <- Rmult_assoc; rewrite <- Rinv_r_sym.
  rewrite Rmult_1_l; rewrite Rmult_comm; fold alpha in |- *.
  apply Rlt_le_trans with (Rmin alpha x).
  apply H9.
  apply Rmin_l.
  red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
  apply Rle_ge; left; apply H.
  red in |- *; intro; rewrite H10 in H; elim (Rlt_irrefl _ H).
  assert (H7 := sqrt_lt_R0 x H).
  red in |- *; intro; rewrite H8 in H7; elim (Rlt_irrefl _ H7).
  apply Rle_ge; apply sqrt_positivity.
  left; apply H.
  unfold Rminus in |- *; rewrite Rmult_plus_distr_l;
    rewrite Ropp_mult_distr_r_reverse; repeat rewrite <- sqrt_mult.
  rewrite Rmult_1_r; rewrite Rmult_plus_distr_l; rewrite Rmult_1_r;
    unfold Rdiv in |- *; rewrite Rmult_comm; rewrite Rmult_assoc;
      rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; reflexivity.
  red in |- *; intro; rewrite H7 in H; elim (Rlt_irrefl _ H).
  left; apply H.
  left; apply Rlt_0_1.
  left; apply H.
  elim H6; intros.
  case (Rcase_abs (x0 - x)); intro.
  rewrite (Rabs_left (x0 - x) r) in H8.
  rewrite Rplus_comm.
  apply Rplus_le_reg_l with (- ((x0 - x) / x)).
  rewrite Rplus_0_r; rewrite <- Rplus_assoc; rewrite Rplus_opp_l;
    rewrite Rplus_0_l; unfold Rdiv in |- *; rewrite <- Ropp_mult_distr_l_reverse.
  apply Rmult_le_reg_l with x.
  apply H.
  rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
    rewrite <- Rinv_l_sym.
  rewrite Rmult_1_r; left; apply Rlt_le_trans with (Rmin alpha x).
  apply H8.
  apply Rmin_r.
  red in |- *; intro; rewrite H9 in H; elim (Rlt_irrefl _ H).
  apply Rplus_le_le_0_compat.
  left; apply Rlt_0_1.
  unfold Rdiv in |- *; apply Rmult_le_pos.
  apply Rge_le; exact r.
  left; apply Rinv_0_lt_compat; apply H.
  unfold Rdiv in |- *; apply Rmult_lt_0_compat.
  apply H1.
  apply Rinv_0_lt_compat; apply sqrt_lt_R0; apply H.
Qed.

(** sqrt is derivable for all x>0 *)
Lemma derivable_pt_lim_sqrt :
  forall x:R, 0 < x -> derivable_pt_lim sqrt x (/ (2 * sqrt x)).
Proof.
  intros; set (g := fun h:R => sqrt x + sqrt (x + h)).
  cut (continuity_pt g 0).
  intro; cut (g 0 <> 0).
  intro; assert (H2 := continuity_pt_inv g 0 H0 H1).
  unfold derivable_pt_lim in |- *; intros; unfold continuity_pt in H2;
    unfold continue_in in H2; unfold limit1_in in H2;
      unfold limit_in in H2; simpl in H2; unfold R_dist in H2.
  elim (H2 eps H3); intros alpha H4.
  elim H4; intros.
  set (alpha1 := Rmin alpha x).
  cut (0 < alpha1).
  intro; exists (mkposreal alpha1 H7); intros.
  replace ((sqrt (x + h) - sqrt x) / h) with (/ (sqrt x + sqrt (x + h))).
  unfold inv_fct, g in H6; replace (2 * sqrt x) with (sqrt x + sqrt (x + 0)).
  apply H6.
  split.
  unfold D_x, no_cond in |- *.
  split.
  trivial.
  apply (sym_not_eq (A:=R)); exact H8.
  unfold Rminus in |- *; rewrite Ropp_0; rewrite Rplus_0_r;
    apply Rlt_le_trans with alpha1.
  exact H9.
  unfold alpha1 in |- *; apply Rmin_l.
  rewrite Rplus_0_r; ring.
  cut (0 <= x + h).
  intro; cut (0 < sqrt x + sqrt (x + h)).
  intro; apply Rmult_eq_reg_l with (sqrt x + sqrt (x + h)).
  rewrite <- Rinv_r_sym.
  rewrite Rplus_comm; unfold Rdiv in |- *; rewrite <- Rmult_assoc;
    rewrite Rsqr_plus_minus; repeat rewrite Rsqr_sqrt.
  rewrite Rplus_comm; unfold Rminus in |- *; rewrite Rplus_assoc;
    rewrite Rplus_opp_r; rewrite Rplus_0_r; rewrite <- Rinv_r_sym.
  reflexivity.
  apply H8.
  left; apply H.
  assumption.
  red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
  red in |- *; intro; rewrite H12 in H11; elim (Rlt_irrefl _ H11).
  apply Rplus_lt_le_0_compat.
  apply sqrt_lt_R0; apply H.
  apply sqrt_positivity; apply H10.
  case (Rcase_abs h); intro.
  rewrite (Rabs_left h r) in H9.
  apply Rplus_le_reg_l with (- h).
  rewrite Rplus_0_r; rewrite Rplus_comm; rewrite Rplus_assoc;
    rewrite Rplus_opp_r; rewrite Rplus_0_r; left; apply Rlt_le_trans with alpha1.
  apply H9.
  unfold alpha1 in |- *; apply Rmin_r.
  apply Rplus_le_le_0_compat.
  left; assumption.
  apply Rge_le; apply r.
  unfold alpha1 in |- *; unfold Rmin in |- *; case (Rle_dec alpha x); intro.
  apply H5.
  apply H.
  unfold g in |- *; rewrite Rplus_0_r.
  cut (0 < sqrt x + sqrt x).
  intro; red in |- *; intro; rewrite H2 in H1; elim (Rlt_irrefl _ H1).
  apply Rplus_lt_0_compat; apply sqrt_lt_R0; apply H.
  replace g with (fct_cte (sqrt x) + comp sqrt (fct_cte x + id))%F;
  [ idtac | reflexivity ].
  apply continuity_pt_plus.
  apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
    reflexivity.
  apply continuity_pt_comp.
  apply continuity_pt_plus.
  apply continuity_pt_const; unfold constant, fct_cte in |- *; intro;
    reflexivity.
  apply derivable_continuous_pt; apply derivable_pt_id.
  apply sqrt_continuity_pt.
  unfold plus_fct, fct_cte, id in |- *; rewrite Rplus_0_r; apply H.
Qed.

(**********)
Lemma derivable_pt_sqrt : forall x:R, 0 < x -> derivable_pt sqrt x.
Proof.
  unfold derivable_pt in |- *; intros.
  exists (/ (2 * sqrt x)).
  apply derivable_pt_lim_sqrt; assumption.
Qed.

(**********)
Lemma derive_pt_sqrt :
  forall (x:R) (pr:0 < x),
    derive_pt sqrt x (derivable_pt_sqrt _ pr) = / (2 * sqrt x).
Proof.
  intros.
  apply derive_pt_eq_0.
  apply derivable_pt_lim_sqrt; assumption.
Qed.

(** We show that sqrt is continuous for all x>=0 *)
(** Remark : by definition of sqrt (as extension of Rsqrt on |R),
   we could also show that sqrt is continuous for all x *)
Lemma continuity_pt_sqrt : forall x:R, 0 <= x -> continuity_pt sqrt x.
Proof.
  intros; case (Rtotal_order 0 x); intro.
  apply (sqrt_continuity_pt x H0).
  elim H0; intro.
  unfold continuity_pt in |- *; unfold continue_in in |- *;
    unfold limit1_in in |- *; unfold limit_in in |- *;
      simpl in |- *; unfold R_dist in |- *; intros.
  exists (Rsqr eps); intros.
  split.
  change (0 < Rsqr eps) in |- *; apply Rsqr_pos_lt.
  red in |- *; intro; rewrite H3 in H2; elim (Rlt_irrefl _ H2).
  intros; elim H3; intros.
  rewrite <- H1; rewrite sqrt_0; unfold Rminus in |- *; rewrite Ropp_0;
    rewrite Rplus_0_r; rewrite <- H1 in H5; unfold Rminus in H5;
      rewrite Ropp_0 in H5; rewrite Rplus_0_r in H5.
  case (Rcase_abs x0); intro.
  unfold sqrt in |- *; case (Rcase_abs x0); intro.
  rewrite Rabs_R0; apply H2.
  assert (H6 := Rge_le _ _ r0); elim (Rlt_irrefl _ (Rle_lt_trans _ _ _ H6 r)).
  rewrite Rabs_right.
  apply Rsqr_incrst_0.
  rewrite Rsqr_sqrt.
  rewrite (Rabs_right x0 r) in H5; apply H5.
  apply Rge_le; exact r.
  apply sqrt_positivity; apply Rge_le; exact r.
  left; exact H2.
  apply Rle_ge; apply sqrt_positivity; apply Rge_le; exact r.
  elim (Rlt_irrefl _ (Rlt_le_trans _ _ _ H1 H)).
Qed.


(* -*- coq-prog-args: ("-type-in-type"); -*- *)

(** * Exercises on Synthetic Homotopy Theory

Peter LeFanu Lumsdaine
School on Univalent Mathematics, Cortona, July 2022
https://unimath.github.io/cortona2022/

The goal is to remove as many “Admitted” as possible in the code below.  The exercises should range from straightforward to very challenging.

The exercises are divided into 8 groups, each forming a roughly self-contained story.  In earlier groups, all statements and most definitions are given, only proofs are missing; in later groups, less is given, and more is left for the student.  Apart from the core definitions in group 0, most later groups don’t depend essentially on earlier groups.

The biggest and most interesting part is group 4 — showing the fundamental group of the circle is the integers.  Groups 1–3 can largely be seen as warm-up exercises for this.  Depending on taste, I recommend either tackling the file roughly in order, or jumping straight to group 4 and looking back to earlier exercises as necessary.

A few exercises are marked “off-topic”, when their difficulty is not really related to synthetic homotopy theory.  They’re included either because their statements are good to see, or because they’re needed in later exercises; they can all safely be left as “admitted”.  They may be good exercises on other topics — mostly on working with UniMath’s integers — but insofar as you want exercises on synthetic homotopy theory, I recommend skipping them to avoid getting bogged down.

- Group 0: Circle structure
- Group 1: Basics
- Group 2: The circle is unique
- Group 3: The circle is non-trivial
- Group 4: Fundamental group of the circle
- Group 5: Being a circle is a proposition
- Group 6: The recursor is equivalent to the universal mapping property.
- Group 7: Is the circle’s computation rule necessary?
- Group 8: Implementing the circle using Z-torsors

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.NumberSystems.All.

(** * Auxiliary functions

Almost every development ends up needing a few “auxiliary” definitions that don’t really belong in the development itself, but don’t exist upstream.  There are various ways to deal with this; I like to put them in an “auxiliary” file or section, and then upstream them later when there’s a suitable moment.  *)
Section Auxiliary.

  (** Generalisation of [maponpaths] to dependent functions. *)
  Definition maponpaths_dep {X:UU} {Y : X -> UU}
      (f : ∏ x:X, Y x) {x1 x2} (e : x1 = x2)
    : transportf _ e (f x1) = f x2.
  Proof.
    destruct e. apply idpath.
  Defined.

End Auxiliary.

(** * Group 0: Circle structure

Definition of circles, as their universal property. *)

Section Circle_Structure.

  (** This axiomatises the recursor on a type that shows it is “the” circle. *)
  Definition circle_rec_structure {S : UU} {b : S} (l : b = b) : UU
  := ∏ (Y : S -> UU) (y_b : Y b) (y_l : transportf _ l y_b = y_b),
     ∑ (f : ∏ x:S, Y x)
       (e_b : f b = y_b),
         maponpaths_dep f l
       = maponpaths _ e_b @ y_l @ !e_b.
  (** The third component (the “computation rule” on the loop) is a bit complicated: the idea is just [maponpaths_dep f l = y_l], but that is only well-typed modulo via the “computation rule” for the basepoint, [e_b : f b = y_b]. *)

  (* With any multiple-component definition, it’s good practice to provide named access functions.  (Compared to accessing via lots of [pr1], [pr2], this is both more readable, and more robust for refactoring.) *)
  Definition circle_rec
      {S : UU} {b : S} {l : b = b} (H : circle_rec_structure l)
      {Y : S -> UU} {y_b : Y b} (y_l : transportf _ l y_b = y_b)
    : ∏ x:S, Y x.
  Proof.
  Admitted.

  Definition circle_rec_comp_base
      {S : UU} {b : S} {l : b = b} (H : circle_rec_structure l)
      {Y : S -> UU} {y_b : Y b} (y_l : transportf _ l y_b = y_b)
    : circle_rec H y_l b = y_b.
  Proof.
  Admitted.

  Definition circle_rec_comp_loop
      {S : UU} {b : S} {l : b = b} (H : circle_rec_structure l)
      {Y : S -> UU} {y_b : Y b} (y_l : transportf _ l y_b = y_b)
    : maponpaths_dep (circle_rec H y_l) l
    = maponpaths _ (circle_rec_comp_base _ _)
      @ y_l @ ! (circle_rec_comp_base _ _).
  Proof.
  Admitted.

  (** An alternative formulation of the universal property of the circle:
  maps out of it correspond to loops.

  “UMP” stands for the “universal mapping property” (a term category theorists love) *)
  Definition circle_ump_structure {S : UU} {b : S} (l : b = b) : UU
  := ∏ (Y : UU),
       isweq ((fun f => (f b,, maponpaths f l)) : (S -> Y) -> (∑ y:Y, y = y)).

  (* Later, when you need to use [circle_ump_structure], come back here and write access functions for it. *)

End Circle_Structure.

(** * Group 1: Basics

Various fairly straightforward exercises: some that we will need later, others that are warmups for harder things later. *)
Section Basics.

  (* Section contexts are the Coq equivalent of writing “Fix some choice of circle (S,b,l)…”  Within the section, these variables are fixed parameters that are available for all results/constructions.  After the section, all results/constructions get generalised over whichever of the variables they used: see the “Check” commands below to demonstrate this. *)
  Context {S : UU} {b : S} (l : b = b).

  Proposition isaprop_circle_ump_structure : isaprop (circle_ump_structure l).
  (* TODO: suggest some useful lemmas, or the search command to search for them *)
  Admitted.

  Definition loop_pos_power : nat -> (b = b).
  Admitted.

  (* off-topic *)
  Definition loop_power : hz -> (b = b).
  (* Use [Search hz] to find general results about hz. *)
  Admitted.
  (* Eventually, we want to show [(b = b) ≃ hz]. *)

  (* Within the section, the variables [S] etc are a fixed context, not shown explicitly in the individual types: *)
  Check loop_power.
End Basics.
(* After closing the section, the section variables are generalised: *)
Check loop_power.
(* In actual developments, it’s usually considered bad practice to leave “noisy” commands like “Check”, “Search” etc. in finished proof scripts — better to just issue them as queries in your IDE. *)

(** * Group 2: the circle is unique

Goal of this group: any two circles are canonically equivalent. *)
Section Circle_Unique.

  Context {S : UU} {b : S} {l : b = b} (is_circ : circle_rec_structure l).
  Context {S' : UU} {b' : S'} {l' : b' = b'} (is_circ' : circle_rec_structure l').

  (* It’s often helpful to make auxiliary definitions _local_ to their section or file.  This means that in later files, this can only be accessed as [Circle_Unique.S_to_S'].  If this definition was not marked “local”, then we should give it a more carefully considered name. *)
  Local Definition S_to_S' : S -> S'.
  Admitted.

  (* This definition could be copy-pasted from [S_to_S'] above; or to avoid code-duplication, you could generalise the variables in that (either by closing the section and opening a new one, or by moving the section variables explicitly to its hypotheses) and then taking this just as an instance of that. *)
  Local Definition S'_to_S : S' -> S.
  Admitted.

  Local Definition S_to_S'_to_S : S'_to_S ∘ S_to_S' = idfun S.
  Admitted.

  Local Definition S'_to_S_to_S' : S_to_S' ∘ S'_to_S = idfun S'.
  Admitted.

  Proposition weq_circle_unique : S ≃ S'.
  Proof.
    (* the lemma [gradth] is often useful for constructing equivalences *)
  Admitted.

  (** Optional extra: State and prove the fact that this equivalence is “canonical” — it’s the unique equivalence between [S] and [S'] mapping [l] to [l']. *)

End Circle_Unique.

(** * Group 3: The circle is non-trivial

Using univalence, we can show that the circle is non-trivial. *)
Section Circle_non_trivial.

  (** Outline:
     - if the circle was trivial, then every type would be a set
     - the universe is not a set, since [bool] has a non-trivial automorphism
  *)

  Context {S : UU} {b : S} {l : b = b} (S_circ : circle_rec_structure l).

  Proposition circle_trivial_implies_loops_trivial
    : iscontr S -> ∏ (X:UU) (x:X) (l : x=x), l = idpath x.
  Admitted.

  Proposition loops_trivial_implies_isaset {X:UU}
    : (∏ (x:X) (l : x=x), l = idpath x) -> isaset X.
  Admitted.

  Proposition circle_trivial_implies_isaset
    : iscontr S -> ∏ (X:UU), isaset X.
  Admitted.

  Definition flip : bool ≃ bool.
  (* You can either write this yourself, or look for it in [UniMath] iwth [Search (bool ≃ bool)], or [Search (weq bool bool)] if your command prompt makes unicode entry difficult. *)
  Admitted.

  Proposition flip_neq_idweq : flip != idweq bool.
    (* this uses the fact that [false != true];
     you can either prove this yourself or search for it in [UniMath] *)
  Admitted.

  Definition flip_path : bool = bool.
    (* this is of univalence; specifically, [weqtopaths] *)
  Admitted.

  Proposition flip_path_neq_idpath : flip_path != idpath bool.
    (* hints: [Search weqtopaths], [Search eqweqmap], [maponpaths] *)
  Admitted.

  Proposition not_isaset_uu : ¬ isaset UU.
  Admitted.

  Proposition not_iscontr_circle : ¬ iscontr S.
  Admitted.

  (** Optional extra: can you strengthen the conclusion of this section? *)
End Circle_non_trivial.

(** * Group 4: Fundamental group of the circle

In this sequence, we show that the fundamental group of the circle is the integers.

Indeed, we show the slightly stronger statement that the _loop space_ of the circle is equivalent to the integers.  (The fundamental group is the set-truncation of the loop space.) *)
Section Fundamental_Group.

  (** Fix a circle type throughout this sequence. *)
  Context {Circle : UU} {base : Circle} (loop : base = base).

  (** Outline:
  - (1) the identity-types Id_A(a,x) form the free A-indexed family generated by a single element at a; in particular, Id_S(b,x) are the free S-indexed family generated by an element at b
  - (2) by univalence, a family over a circle (S,b,l) corresponds to a single type equipped with an auto-equivalence
  - (3) so Id_S(b,b) is the free type-with-auto-equivalence generated by a single element
  - (4) (Z,succ) is the free type-with-auto-equivalence generated by a single element
  - (5) so they have the same universal peroperty, so are equivalent.

  We do not attempt to make all these results fully precise (especially (1), (2)); but they motivate the steps we use, which are just as much of the above results as are needed to make this argument go through. *)

  (** Step (1) is nothing specifically to do with the circle,
  just a particular formulation of the universal property of path-types *)

  Section Family_Maps_From_Path_Types.

    Context {X:UU} (x0:X).

    Proposition unique_family_map_from_paths {Y : X -> UU} (y0 : Y x0)
      : iscontr (∑ (f : ∏ x:X, x0 = x -> Y x), f x0 (idpath _) = y0).
    Admitted.

  End Family_Maps_From_Path_Types.

  Section Auto_Types.
  (** In the rest of the proof, we work with types equipped with with an auto-equivalence, and sometimes also with a distinguished element.  For conciseness, call these *auto-types* and *pointed auto-types*.

  We set these up explicitly as bundled structures, with access functions and a constructor function. *)

    Definition auto_type : UU := ∑ (X:UU), X ≃ X.

    Definition auto_type_pr1 : auto_type -> UU := pr1.
    Coercion auto_type_pr1 : auto_type >-> UU.

    Definition auto_type_auto { X : auto_type } : X ≃ X
      := pr2 X.

    (* a constructor function is good practice in general,
  but especially necessary in this case since Coq doesn’t generally accept [(X,,e)] for an auto-type: it de-sugars this to [tpair _ X e] and fails to infer the implicit argument correctly *)
    Definition make_auto_type {X:UU} (e : X ≃ X) : auto_type
      := tpair (fun Y => Y ≃ Y) X e.

    Definition ptd_auto_type : UU := ∑ (X:auto_type), X.

    Definition ptd_auto_type_pr1 : ptd_auto_type -> auto_type := pr1.
    Coercion ptd_auto_type_pr1 : ptd_auto_type >-> auto_type.

    Definition ptd_auto_type_pt ( X : ptd_auto_type ) : X
      := pr2 X.

    Definition make_ptd_auto_type {X:UU} (e : X ≃ X) (x0 : X) : ptd_auto_type
      := (make_auto_type e ,, x0).
  End Auto_Types.

  (* we give more concise names, but keep them local *)
  Local Definition s {X : auto_type} := @auto_type_auto X.
  Local Definition pt {X : ptd_auto_type} := @ptd_auto_type_pt X.

  (** We define “freeness” in a category-theoretic style, using a universal mapping property: *)
  Definition free_ptd_auto_type_ump_structure (X : ptd_auto_type) : UU
  := ∏ (Y : ptd_auto_type),
      iscontr (∑ (f : ∑ (f : X -> Y), f ∘ s = s ∘ f), (pr1 f pt = pt)).
  (** a more natural and readable phrasing would be
     [ ∑ (f : X -> Y), (f ∘ s = s ∘ f) × (f pt = pt) ]
  but associating the first two components together fits much better with the ways we’ll use it below *)

  (* When you use this below, you’ll probably want to come back and write access functions! *)

  (* It might be helpful to bundle “ptd-auto-preserving maps” as a structure following how we bundled ptd-auto-types. *)

  (** Step (2): families over circle correspond to types-with-automorphisms.

  We don’t give a very complete form of this “correspondence” — just as is needed in later steps of the proof. *)

  Section Families_Over_Circle.

    Definition circle_family_of_auto_type
      : auto_type -> (Circle -> UU).
    Admitted.

    Definition auto_type_of_circle_family
      : (Circle -> UU) -> auto_type.
    Admitted.

    (** The above two functions should form an equivalence; but we need only one direction of their inverse-ness. *)
    Definition auto_type_of_circle_family_of_auto_type
        (X : auto_type)
      : auto_type_of_circle_family (circle_family_of_auto_type X)
      = X.
    (* In this kind of situation, it’s often helpful to give a general lemma for building paths of auto-types, named e.g. [auto_type_path],
      saying that to show two auto-types equal, it suffices to give an equality [e] between their types, and show their automorphisms commute with the equivalence [eqweqmap e] *)
    Admitted.

    Definition weq_family_maps_auto_type_maps {X Y : Circle -> UU}
      : (∏ p:Circle, X p -> Y p)
        ≃ (∑ (f : auto_type_of_circle_family X
                  -> auto_type_of_circle_family Y),
            (f ∘ s = s ∘ f)).
    Proof.
      (* look for library lemmas for building equivalences between dependent sum types,
       e.g. [Search ((∑ (x:_), _) ≃ (∑ (x:_), _))] *)
    Admitted.

  End Families_Over_Circle.

  (** Step (3): [ loop = loop ] is a _free_ pointed-type-with-auto-equivalence.  *)
  Section Circle_Loops_Free.

    Definition circle_ptd_auto : ptd_auto_type.
    Proof.
      refine (@make_ptd_auto_type (base = base) _ _).
      - admit.
      - admit.
    Admitted.

    Definition circle_is_free_ptd_auto_type
      : free_ptd_auto_type_ump_structure circle_ptd_auto.
    (* Need to show: for any other ptd-auto-type, there’s a unique structure-preserving map to it.
    By results above, we know:
    - every ptd-auto-type arises from a family over S;
    - in that case, auto-preserving maps to it correspond to family-maps to it;
    - and then tre’s a unique point-preserving family-map to it.

    This proof is where it should be helpful that in the definition of [free_ptd_auto_type_ump_structure], we grouped “auto-preserving-map” together inside “point-preserving, auto-preserving map. *)
    Admitted.

  End Circle_Loops_Free.

  (** Step (4): the integers (with successor and zero) are also a free pointed-auto-type.

  This section involves no homotopy theory — it’s almost entirely old-fashioned set-level mathematics.  The “almost” is because the universal property we want involves mapping into arbitrary _types_, not just sets. *)

  Section Integers_Free.

    (* off-topic *)
    (* [hz] is UniMath’s integers *)
    Definition hz_ptd_auto : ptd_auto_type.
    Proof.
      refine (@make_ptd_auto_type hz _ _).
      - admit.
      - admit.
    Admitted.

    (* off-topic *)
    Definition hz_is_free_ptd_auto_type
      : free_ptd_auto_type_ump_structure hz_ptd_auto.
    (* One possible approach: show that the integers are equivalent to the coproduct of two copies of the naturals (viewed as e.g. the positive and strictly-negative integers); then give the required map (and its uniqueness) by induction over each copy of the naturals separately. *)
    Admitted.

  End Integers_Free.

  (** Step (5): we’ve shown that the integers and the loop space of the circle are each a “free pointed auto-type”. Now we use that to show they’re equivalent. *)
  Section Free_Ptd_Auto_Type_Unique.

    Definition weq_free_ptd_auto_type_unique
        {X : ptd_auto_type} (X_free : free_ptd_auto_type_ump_structure X)
        {X' : ptd_auto_type} (X'_free : free_ptd_auto_type_ump_structure X')
      : X ≃ X'.
    Admitted.

  End Free_Ptd_Auto_Type_Unique.

  Theorem weq_circle_loops_hz : (base = base) ≃ hz.
  Proof.
    (* now this should be just putting together earlier results, as sketched at the start! *)
  Admitted.

  (** Optional extra: we could instead define “freeness” in a more type-theoretic style, as a dependent recursion principle.  Using that approach in the proof would be an interesting extra challenge; if you do that, I’d be very interested to see it! *)
  Definition free_pointed_auto_type_rec_structure {X:UU} (s:X ≃ X) (x0:X) : UU
  := ∏ (Y : X -> UU) (s_y : ∏ x:X, Y x ≃ Y (s x)) (y0 : Y x0),
      ∑ (f : ∏ x:X, Y x) (_ : ∏ x, s_y x (f x) = f (s x)), (f x0 = y0).

End Fundamental_Group.

(** * Group 5: being a circle is a proposition

Precisely: for a given type, basepoint, and loop [l], [circle_rec_structure l] is a proposition. *)
Section Circle_Rec_Structure_Unique.

  Context {S : UU} {b : S} (l : b = b).

  Definition isaprop_circle_rec_conclusion
    : circle_rec_structure l
    -> ∏ (Y : S -> UU) (y_b : Y b) (y_l : transportf _ l y_b = y_b),
      isaprop
      ( ∑ (f : ∏ x:S, Y x)
        (e_b : f b = y_b),
          maponpaths_dep f l
        = maponpaths _ e_b @ y_l @ !e_b).
  (* hint: if you attack this directly by hand, it’s quite nasty;
    you will probably want lemmas about how to construct paths in sigma-types, which are available in the library,
    and also about lemmas about how [maponpaths_dep] interacts with path-composition, etc, which you will have to prove yourself *)
  Admitted.

  Definition isaprop_circle_rec_structure
    : isaprop (circle_rec_structure l).
  (* hint: look for a general result in the library to deduce this from the preceding result *)
  Admitted.

End Circle_Rec_Structure_Unique.

(** * Group 6: the recursor is equivalent to the universal mapping property. *)

Section Circle_Rec_Equiv_UMP.

  Context {S : UU} {b : S} (l : b = b).

  Definition circle_ump_from_rec
    : circle_rec_structure l -> circle_ump_structure l.
  Admitted.

  Definition circle_rec_from_ump
    : circle_ump_structure l -> circle_rec_structure l.
  Admitted.

  Definition weq_circle_rec_circle_ump
    : circle_ump_structure l ≃ circle_rec_structure l.
  (* we’ve shown both sides are propositions, and they imply each other;
  now look for a general result in the library to put these together *)
  Admitted.

End Circle_Rec_Equiv_UMP.

(** * Group 7: is the circle’s computation rule necessary?

Are the “computation rules” in the universal property of the circle really required, or are then unnecessary?  Prove or disprove! *)
Section Comp_Rule_Redundant.

  (** A weakened form of [circle_rec_structure], omitting the “computation rules” *)
  Definition weak_circle_rec_structure {S : UU} {b : S} (l : b = b) : UU
  := ∏ (Y : S -> UU) (y_b : Y b) (y_l : transportf _ l y_b = y_b),
     ∏ x:S, Y x.

  Definition comp_rule_redundant : UU
  := ∏ (X:UU) (b:X) (l:b=b),
      weak_circle_rec_structure l -> circle_rec_structure l.

  Theorem comp_rule_redundant_or_necessary
    : comp_rule_redundant ∨ ¬ comp_rule_redundant.
  Proof.
  (** Are the computation rules redundant?  Either prove they are, or disprove by giving a counterexample! *)
  Admitted.

End Comp_Rule_Redundant.

(** * Group 8: Implementing the circle using Z-torsors

The goal of the type is to give an implementation of the circle: we define “Z-torsors”, and show that the type of Z-torsors is a circle.

The proof is only very roughly outlined — fleshing out the structure of the section is entirely left for the student. *)
Section Z_torsors.

  Definition hz_auto : auto_type.
  (* probably better to define this not here, but upstream as a component of the definition of [hz_ptd_auto] *)
  Admitted.

  (** There is a general definition of “G-torsor” for an arbitrary group G.

  We don’t give the general definition, but a simplified definition for the special case where G is the integers. *)
  Definition Z_torsor : UU
  := ∑ (X : auto_type), ∥ X = hz_auto ∥.

  Local Definition base : Z_torsor.
  Admitted.

  Local Definition loop : base = base.
  Admitted.

  Theorem Z_torsors_circle : circle_rec_structure loop.
  Proof.
  (* quite long, and quite mathematically substantial! *)
  Admitted.

End Z_torsors.

(*
*** Local Variables: ***
*** coq-prog-args: ("-type-in-type") ***
*** End: ***
*)


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Terminal.
Require Import Category.Structure.Initial.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cartesian.Closed.
Require Import Category.Structure.Cocartesian.
Require Import Category.Instance.Sets.

Generalizable All Variables.

#[local] Obligation Tactic := cat_simpl.

Inductive Obj : Set :=
  | One_    : Obj
  | Prod_   : Obj → Obj → Obj
  | Exp_    : Obj → Obj → Obj
  | Zero_   : Obj
  | Coprod_ : Obj → Obj → Obj.

Fixpoint denote `(o : Obj) :
  ∀ {C : Category}
    {A : @Cartesian C}
    `{@Closed C A}
    `{@Cocartesian C}
    `{@Terminal C}
    `{@Initial C}, C := fun _ _ _ _ _ _ =>
  match o with
  | One_        => 1
  | Prod_ x y   => denote x × denote y
  | Exp_ x y    => denote y ^ denote x
  | Zero_       => 0
  | Coprod_ x y => denote x + denote y
  end.

Inductive Hom : Obj → Obj → Set :=
  | Id      : ∀ {a}, Hom a a
  | Compose : ∀ {a b c}, Hom b c → Hom a b → Hom a c

  | One'    : ∀ {a}, Hom a One_

  | Exl     : ∀ {a b}, Hom (Prod_ a b) a
  | Exr     : ∀ {a b}, Hom (Prod_ a b) b
  | Fork    : ∀ {a c d}, Hom a c → Hom a d → Hom a (Prod_ c d)

  | Curry   : ∀ {a b c}, Hom (Prod_ a b) c → Hom a (Exp_ b c)
  | Uncurry : ∀ {a b c}, Hom a (Exp_ b c) → Hom (Prod_ a b) c

  | Zero'   : ∀ {a}, Hom Zero_ a

  | Inl     : ∀ {a b}, Hom a (Coprod_ a b)
  | Inr     : ∀ {a b}, Hom b (Coprod_ a b)
  | Merge   : ∀ {a c d}, Hom c a → Hom d a → Hom (Coprod_ c d) a.

Program Fixpoint interp `(c : Hom a b) :
  ∀ {C : Category}
    {A : @Cartesian C}
    `{@Closed C A}
    `{@Cocartesian C}
    `{@Terminal C}
    `{@Initial C}, denote a ~{C}~> denote b := fun _ _ _ _ _ _ =>
  match c with
  | Id          => id
  | Compose f g => interp f ∘ interp g

  | One'        => one

  | Exl         => exl
  | Exr         => exr
  | Fork f g    => fork (interp f) (interp g)

  | Curry f     => curry (interp f)
  | Uncurry f   => uncurry (interp f)

  | Zero'       => zero

  | Inl         => inl
  | Inr         => inr
  | Merge f g   => merge (interp f) (interp g)
  end.

#[export]
Program Instance AST : Category := {
  obj     := Obj;
  hom     := Hom;
  id      := @Id;
  compose := @Compose;
  homset  := fun _ _ =>
    {| equiv := fun f g =>
         ∀ (C : Category)
                (A : @Cartesian C)
                `(@Closed C A)
                `(@Cocartesian C)
                `(@Terminal C)
                `(@Initial C),
           interp f ≈ interp g |}
}.
Next Obligation.
  equivalence.
  transitivity (interp y); auto.
Qed.

#[export]
Program Instance Hom_Terminal : @Terminal AST := {
  terminal_obj := One_;
  one := @One'
}.
Next Obligation. apply one_unique. Qed.

#[export]
Program Instance Hom_Cartesian : @Cartesian AST := {
  product_obj := Prod_;
  fork := @Fork;
  exl  := @Exl;
  exr  := @Exr
}.
Next Obligation. proper; rewrite X, X0; reflexivity. Qed.
Next Obligation.
  split; intros HA.
  - split; intros; rewrite HA; cat.
  - intros.
    destruct HA as [? ?].
    rewrite <- e, <- e0.
    rewrite fork_comp; cat.
Qed.

#[export]
Program Instance Hom_Closed : @Closed AST _ := {
  exponent_obj := Exp_;
  exp_iso := fun x y z =>
    {| to   := {| morphism := @Curry x y z |}
     ; from := {| morphism := @Uncurry x y z |} |}
}.
Next Obligation. proper; rewrite X; reflexivity. Qed.
Next Obligation. proper; rewrite X; reflexivity. Qed.

#[export]
Program Instance Hom_Initial : @Initial AST := {
  terminal_obj := Zero_;
  one := @Zero'
}.
Next Obligation. apply zero_unique. Qed.

#[export]
Program Instance Hom_Cocartesian : @Cocartesian AST := {
  product_obj := Coprod_;
  fork := @Merge;
  exl  := @Inl;
  exr  := @Inr
}.
Next Obligation. proper; rewrite X, X0; reflexivity. Qed.
Next Obligation.
  split; intros HA.
  - split; intros; rewrite HA; cat.
  - intros.
    destruct HA as [? ?].
    rewrite <- e, <- e0.
    rewrite merge_comp; cat.
Qed.

#[export]
Program Instance interp_proper {x y : Obj}
        {C : Category} {A : @Cartesian C}
        `{@Closed C A} `{@Cocartesian C}
        `{@Terminal C} `{@Initial C} :
  Proper (@equiv _ (@homset AST x y) ==>
                     @equiv _ (@homset C _ _))
         (fun f => @interp x y f C A _ _ _ _).


(* -*- mode: coq; mode: visual-line -*- *)
(** * Varieties of univalence *)

Require Import HoTT.Basics HoTT.Types.
Require Import Fibrations Idempotents EquivalenceVarieties UnivalenceImpliesFunext.
Local Open Scope path_scope.

(** The standard univalence axiom type [Univalence_type] is defined in [UnivalenceImpliesFunext]. *)

(** A weaker form that only asserts that we can make equivalences into paths with a computation rule (no uniqueness rule). *)
Definition WeakUnivalence :=
  { etop : forall A B, (A <~> B) -> (A = B) &
    forall A B (f : A <~> B), equiv_path A B (etop A B f) = f }.

(** The same thing, stated with an incoherent notion of equivalence but a pointwise equality for the computation rule.  *)
Definition IncoherentWeakUnivalence :=
  { etop : forall A B (f : A -> B) (g : B -> A),
      (f o g == idmap) -> (g o f == idmap) -> (A = B) &
    forall A B f g H K, equiv_path A B (etop A B f g H K) == f }.

(** Finally, it even suffices to consider only just a few special cases. This is due to Ian Orton and Andrew Pitts. *)
Record VeryWeakUnivalence :=
  { unit : forall A, A = { a : A & Unit };
    flip : forall A B (C : A -> B -> Type),
        { a : A & { b : B & C a b }} = { b : B & { a : A & C a b }};
    contract : forall A, Contr A -> A = Unit;
    unit_comp : forall A a, transport idmap (unit A) a = (a;tt);
    flip_comp : forall A B C (a:A) (b:B) (c : C a b),
        transport idmap (flip A B C) (a ; (b ; c)) = (b ; (a ; c))
  }.

Theorem WeakUnivalence_implies_Univalence :
  WeakUnivalence -> Univalence_type.
Proof.
  intros [etop H] A.
  apply isequiv_from_functor_sigma.
  serapply isequiv_contr_contr.
  serapply (contr_retracttype
            (Build_RetractOf _ _
                             (fun Be => (Be.1 ; equiv_path A Be.1 Be.2))
                             (fun Bf => (Bf.1 ; etop A Bf.1 Bf.2))
                             _)).
  intros [B f].
  refine (path_sigma' (fun B => A <~> B) 1 (H A B f)).
Defined.

(** For this one and the next one, we need to assume funext to start with (so that these forms of univalence, unlike the usual one, probably don't suffice to prove funext from). *)
Theorem IncoherentWeakUnivalence_implies_Univalence `{Funext} :
  IncoherentWeakUnivalence -> Univalence_type.
Proof.
  intros [etop K].
  apply WeakUnivalence_implies_Univalence.
  transparent assert (etop' : (forall A B, (A <~> B) -> (A = B))).
  { intros A B f.
    refine (etop A B f f^-1 _ _).
    - intros x; apply eisretr.
    - intros x; apply eissect. }
  exists etop'.
  intros A B f.
  apply path_equiv, path_arrow, K.
Defined.

Theorem VeryWeakUnivalence_implies_Univalence `{Funext} :
  VeryWeakUnivalence -> Univalence_type.
Proof.
  intros vwu. apply WeakUnivalence_implies_Univalence.
  simple refine (_;_).
  { intros A B f.
    refine (unit vwu A @ _ @ (unit vwu B)^).
    refine (_ @ flip vwu A B (fun a b => f a = b) @ _).
    - apply ap, path_arrow; intros a.
      symmetry; rapply (contract vwu).
    - apply ap, path_arrow; intros b.
      apply (contract vwu), fcontr_isequiv; exact _. }
  { intros A B f.
    apply path_equiv, path_arrow; intros a; cbn.
    rewrite !transport_pp.
    refine (moveR_transport_V idmap (unit vwu B) _ (f a) _).
    rewrite !(unit_comp vwu).
    rewrite <- !transport_compose.
    rewrite (transport_sigma' (C := fun P (a0:A) => P a0)); cbn.
    refine (ap _ _ @ _).
    1:{ apply ap, ap.
        exact (path_contr _ (f a ; 1)). }
    rewrite (flip_comp vwu).
    rewrite transport_sigma'; cbn.
    apply ap, path_contr. }
Defined.