(***********************************************************************)
(** * Definition of STLC *)
(***********************************************************************)

(** This file containes definitions for a locally-nameless
    representation of a Curry-Style simply-typed lambda calculus.
*)

Require Import Metalib.Metatheory.

Require Import Utf8 Arith Compare_dec Lia.
(* equations *)
Set Warnings "-notation-overridden".
Require Import Relation_Operators Program.
Close Scope program_scope.
From Equations Require Import Equations.

Require Export Stlc.Fin.

(***********************************************************************)
(** * Syntax of STLC *)
(***********************************************************************)

(** We use a locally nameless representation for the simply-typed lambda
    calculus, where bound variables are represented as natural numbers
    (de Bruijn indices) and free variables are represented as [atom]s.

    The type [atom], defined in the Metatheory library, represents names.
    Equality on names is decidable, and it is possible to generate an
    atom fresh for any given finite set of atoms ([atom_fresh]).

    Note: the type [var] is notation for [atom].  *)

Inductive typ : Set :=  (*r types *)
 | typ_base : typ
 | typ_arrow (T1:typ) (T2:typ).

Scheme Equality for typ.

(* Expressions are indexed by the number of *bound variables*
   that appear in terms. *)

Inductive exp : nat ->  Set :=  (*r expressions *)
 | var_b : forall {n}, fin n -> exp n
 | var_f : forall {n} (x:var), exp n
 | abs   : forall {n} (e:exp (S n)), exp n
 | app   : forall {n} (e1:exp n) (e2:exp n), exp n.

(* [Signature] creates a sigma type that allowing packing values with their
   constructor index.

   [NoConfusion] creates a heterogenous relation that defines injectivity and
   discrimination of constructors: That is, two values with the same
   constructor are equal if their arguments are also equal. [NoConfusionHom]
   produces a homogenous relation of the same. *)
Derive Signature NoConfusion NoConfusionHom for exp.

(* This should be part of metalib *)
#[local] Instance Atom_EqDec : EqDec Atom.atom := Atom.eq_dec.

(* Decidable equality for expressions *)
Derive Subterm EqDec for exp.

(* Calculate the size of an expression. We could do this
   with equations, but it is simple enough not to. *)
Fixpoint size_exp {n} (e1 : exp n) : nat :=
  match e1 with
    | abs e2 => 1 + (size_exp e2)
    | var_f x1 => 1
    | var_b m => 1
    | app e2 e3 => 1 + (size_exp e2) + (size_exp e3)
  end.

(***********************************************************************)
(** * Substitution *)
(***********************************************************************)

(** Substitution replaces a free variable with a term.  The definition below
    is simple because bound variables are represented using indices. As a
    result, there is no need to worry about variable capture.  *)

(**
    Note that [subst_exp] uses [x == y] for decidable equality.
    This operation is defined in the Metatheory library.

    This definition is defined for *all* scoping levels of the term we are
    substituting into. However, the replacement for y (i.e. the expression u)
    must be compatible with the scoping level for e.
    As a result, we weaken u when going under a binder.

 *)

(* Weaken the number of bound variables allowed in an expression by 1 *)

Equations weaken_exp {n} (e : exp n): exp (S n):= {
  weaken_exp  (var_b m) => var_b (increase_fin m);
  weaken_exp  (var_f x) => var_f x;
  weaken_exp  (abs t)   => abs (weaken_exp t);
  weaken_exp  (app f t) => app (weaken_exp f) (weaken_exp t)
  }.

(* Can also write this as a Fixpoint. But, let's do everything with
   equations*)
(*
Fixpoint weaken_exp {n} (e : exp n) : exp (S n) :=
  match e with
  | var_b m => var_b (increase_fin m)
  | var_f x => var_f x
  | abs t => abs (weaken_exp t)
  | app f t => app (weaken_exp f) (weaken_exp t)
  end. *)

(* Substitute for a free variable. *)
Equations subst_exp_wrt_exp {n} (u:exp n) (y:var) (e:exp n) : exp n :=
  subst_exp_wrt_exp u y (var_b m)   :=
    var_b m;
  subst_exp_wrt_exp u y (var_f x)   :=
    if x == y then u else var_f x;
  subst_exp_wrt_exp u y (abs e1)    :=
    abs (subst_exp_wrt_exp (weaken_exp u) y e1);
  subst_exp_wrt_exp u y (app e1 e2) :=
    app (subst_exp_wrt_exp u y e1) (subst_exp_wrt_exp u y e2).

(***********************************************************************)
(** * Free variables *)
(***********************************************************************)

(** The function [fv_exp], defined below, calculates the set of free
    variables in an expression.  Because we are using a locally
    nameless representation, where bound variables are represented as
    indices, any name we see is a free variable of a term.  In
    particular, this makes the [abs] case simple.
*)

Fixpoint fv_exp {n} (e_5:exp n) : vars :=
  match e_5 with
  | (var_b m)   => {}
  | (var_f x)   => {{x}}
  | (abs e)     => fv_exp e
  | (app e1 e2) => fv_exp e1 `union` fv_exp e2
end.

(** The type [vars] represents a finite set of elements of type [atom].
    The notations for the finite set definitions (empty set `{}`,
    singleton `{{x}}` and union `\u`) is also defined in the Metatheory
    library.  *)

(***********************************************************************)
(** * Opening *)
(***********************************************************************)

(** Opening replaces an index with a term.  It corresponds to informal
    substitution for a bound variable, such as in the rule for beta reduction.
    Note that only "dangling" indices (those that do not refer to any
    abstraction) can be opened, so the index of [exp] must be at least 1.

    In the bound variable case, we check to see if the fin is 0 using
    [decrease_fin]. If it is zero, we found the place for [u].  If it is
    nonzero, we get the same value in a smaller scope.

    We assume that the argument [u] has one fewer "dangling" index than the
    term that we are opening. As with [subst] we need to weaken this term when
    we go under a binder.  *)

(* This is only correct if we call it with exp 0 *)

Equations open_exp_wrt_exp {k:nat} (u:exp k) (e:exp (S k)) : exp k :=
  open_exp_wrt_exp u (var_b m) with decrease_fin k m := {
    | None => u
    | Some f => var_b f
    };
  open_exp_wrt_exp u (var_f x)   := var_f x;
  open_exp_wrt_exp u (abs e)     :=
    abs (open_exp_wrt_exp (weaken_exp u) e);
  open_exp_wrt_exp u (app e1 e2) :=
    app (open_exp_wrt_exp u e1) (open_exp_wrt_exp u e2).

(*
ALTERNATIVE approach.

Equations open_exp_wrt_exp {k:nat} (u:exp 0) (e:exp (S k)) : exp k :=
  open_exp_wrt_exp u (var_b m) :=
     match decrease_fin k m with
        | None => (weaken_exp_by k u)
        | Some f => var_b f
      end;
  open_exp_wrt_exp u (var_f x)   := var_f x;
  open_exp_wrt_exp u (abs e)     :=
    abs (open_exp_wrt_exp u e);
  open_exp_wrt_exp u (app e1 e2) :=
    app (open_exp_wrt_exp u e1) (open_exp_wrt_exp u e2).
*)

(*
Fixpoint open_exp_wrt_exp {k:nat} (u:exp k)
         (e:exp (S k)) : exp k :=
  match e with
  | var_b m => match decrease_fin k m with
        | None => u
        | Some f => var_b f
      end
  | (var_f x) => var_f x
  | (abs e)   =>
      abs (open_exp_wrt_exp (weaken_exp u) e)
  | (app e1 e2) =>
    app (open_exp_wrt_exp u e1) (open_exp_wrt_exp u e2)
  end.
*)

(* Close *)

(** Closing an expression means replacing a free variable x1 with a new bound
   variable.  This increases the binding depth of the expression by 1.
   Existing bound variables must be weakened to the new scope, using
   [increase_fin]. Where we find a free variable that should be bound, we
   introduce it at the current binding depth using [gof].  *)

Equations close_exp_wrt_exp {k : nat} (x1 : var) (e1 : exp k) : exp (S k) :=
  close_exp_wrt_exp x1 (var_b m) :=
    var_b (increase_fin m);
  close_exp_wrt_exp x1 (@var_f k x2) :=
    if (x1 == x2) then (var_b (gof k)) else (var_f x2);
  close_exp_wrt_exp x1 (abs e2) :=
    abs (close_exp_wrt_exp x1 e2);
  close_exp_wrt_exp x1 (app e2 e3) :=
    app (close_exp_wrt_exp x1 e2) (close_exp_wrt_exp x1 e3).


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq tuple ssrfun finfun.
From mathcomp Require Import choice path bigop fintype.
Require Import Lib.Base Ipdl.Exp Ipdl.Core String Ipdl.Lems Big Lib.OrdLems.

(*

  1 := in 5
  2 := 1 + 1
  3 := not 2
  end
*)

Program Definition tuple_trunc {n: nat} {A} (t : n.-tuple A) (j : 'I_n) : j.-tuple A := [tuple of take j t].
Next Obligation.
  apply/minn_idPl.
  destruct j; simpl.
  apply ltnW; done.
Qed.

Lemma tuple_truncE {n} {A} (t : n.-tuple A) (j : 'I_n) :
  val (tuple_trunc t j) = take j t.
  unfold tuple_trunc.
  destruct (tuple_trunc_obligation_1 n j).
  simpl.
  have -> : minn j n = j.
  apply/minn_idPl.
  destruct j; simpl.
  apply ltnW; done.
  done.
Qed.

Lemma leq_ord' {n} (i : 'I_n) : i <= n.
  destruct n.
  destruct i; done.
  eapply leq_trans.
  apply leq_ord.
  apply leqnSn.
Qed.

Lemma tnth_tuple_trunc {n} {A} (j : 'I_n) (t : n.-tuple A) (x : 'I_j) :
  tnth (tuple_trunc t j) x = tnth t (widen_ord (leq_ord' j) x).
  destruct n.
  destruct j; done.
  destruct (tupleP t).
  rewrite !(tnth_nth x0).
  rewrite tuple_truncE.
  simpl.
  rewrite nth_take.
  done.
  destruct x; done.
Qed.

Section CircDef.
  Context (A B : nat).

Inductive Op n :=
  | InA : 'I_A -> Op n
  | InB : 'I_B -> Op n
  | And : 'I_n -> 'I_n -> Op n
  | Xor : 'I_n -> 'I_n -> Op n
  | Not : 'I_n -> Op n.

Definition Circ n := forall (x : 'I_n), Op x.

Definition circOuts n o := o.-tuple ('I_n).

End CircDef.

Definition circ0 {A B} : Circ A B 0.
  intro.
  destruct x.
  done.
Defined.

Definition extend_circ {A B n} (c : Circ A B n) (o : Op A B n) : Circ A B n.+1.
  intro x.
  destruct (ordP_r x).
  subst.
  apply o.
  subst.
  simpl in *.
  apply c.
Defined.

Definition pred_circ {A B n} (c : Circ A B n.+1) : Circ A B n.
  intro j.
  apply (c (widen_ord (leqnSn n) j)).
Defined.

Lemma Circ_ind_r {A B} (P : forall n, Circ A B n -> Prop) :
  P _ circ0 ->
  (forall n c o, P n c -> P n.+1 (extend_circ c o)) ->
  forall n c, P n c.
  intros.
  induction n.
  have -> : c = circ0.
  funext => i.
  destruct i; done.
  done.
  have -> : c = extend_circ (pred_circ c) (c ord_max).
  funext => i.
  rewrite /extend_circ.
  destruct (ordP_r i).
  subst; rewrite /eq_rect_r //=.
  subst; rewrite /eq_rect_r //=.
  apply H0.
  apply IHn.
Qed.

Arguments InA {A B n}.
Arguments InB {A B n}.
Arguments And {A B n}.
Arguments Xor {A B n}.
Arguments Not {A B n}.

Definition evalOp {chan : Type -> Type} {A B n : nat} (inA : A.-tuple (chan bool)) (inB : B.-tuple (chan bool)) (w : n.-tuple (chan bool)) (op : Op A B n) : rxn bool :=
        match op with
            | InA j => copy (tnth inA j)
            | InB j => copy (tnth inB j)
            | And x y => x <-- Read (tnth w x) ;; y <-- Read (tnth w y) ;; Ret (x && y)
            | Xor x y => x <-- Read (tnth w x) ;; y <-- Read (tnth w y) ;; Ret (x (+) y)
            | Not x => x <-- Read (tnth w x) ;; Ret (~~ x) end.

Definition evalCirc {chan : Type -> Type} {A B n : nat} (inA : A.-tuple (chan bool)) (inB : B.-tuple (chan bool)) (c : Circ A B n) (w : n.-tuple (chan bool)) :=
  Outvec w (fun j =>
              evalOp inA inB (tuple_trunc w j) (c j)
           ).


From Coq.Logic Require Import ConstructiveEpsilon.
Require Import Lia Nat.
From stdpp Require Import numbers list list_numbers.
From Undecidability Require Import SemiDecidabilityFacts DecidabilityFacts EnumerabilityFacts reductions Axioms.bestaxioms halting FinChoice.

(** * CT in relation to other axioms  *)

(** ** Provable choice axioms  *)

Lemma decidable_AC X :
  forall R : X -> nat -> Prop, decidable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  destruct (decider_AC _ f R) as [g Hg]; eauto.
Qed.

Lemma semi_decidable_AC X :
  forall R : X -> nat -> Prop, semi_decidable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros R [f Hf] Htot.
  destruct (semi_decider_AC _ f R) as [g Hg]; eauto.
Qed.

Lemma sdec_compute_lor {X} {p q : X -> Prop} :
  semi_decidable p -> semi_decidable q -> (forall x, p x \/ q x) -> exists f : X -> bool, forall x, if f x then p x else q x.
Proof.
  intros Hp Hq Hpq.
  edestruct (semi_decidable_AC X (fun x n => if n is 0 then p x else q x)) as [f Hf].
  - destruct Hp as [f1 H1], Hq as [f2 H2]. red in H1, H2.
    exists (fun '(x,n) m => if n is 0 then f1 x m else f2 x m).
    now intros (x,[]); cbn; rewrite ?H1, ?H2.
  - intros x. destruct (Hpq x). now exists 0. now exists 1.
  - exists (fun x => if f x is 0 then true else false). intros x.
    specialize (Hf x). destruct (f x); firstorder.
Qed.

Lemma inspect_opt {X} (o : option X) :
  {x | o = Some x} + {o = None}.
Proof.
  destruct o; eauto.
Qed.

Lemma enumerable_AC :
  forall X, discrete X -> forall Y, forall R : X -> Y -> Prop, enumerable (curry R) -> (forall x, exists n, R x n) -> exists f, forall x, R x (f x).
Proof.
  intros X [d Hd] Y R [f Hf] Htot.
  destruct (enumerator_AC _ _ f d _ Hd Hf Htot) as [g Hg].
  now exists g.
Qed.

Lemma finite_AC :
  forall X, discrete X -> finiteᵗ X -> forall Y,
    forall R : X -> Y -> Prop, (forall x, exists y, R x y) -> exists f : X -> Y, forall x, R x (f x).
Proof.
  intros X [D] % discrete_iff Hfin Y R Htot.
  eapply finite_choice; auto.
Qed.

(** ** Extensionality axioms  *)

Definition Fext := forall X Y (f g : X -> Y), (forall x, f x = g x) -> f = g.
Definition Pext := forall P Q : Prop, P <-> Q -> P = Q.
Definition hProp (P : Prop) := forall x1 x2 : P, x1 = x2.
Definition PI := forall P : Prop, hProp P.

Lemma Pext_to_PI :
  Pext -> PI.
Proof.
  intros pext P x1 x2.
  assert (P = True) as -> by firstorder.
  now destruct x1, x2.
Qed.

Lemma hProp_disj P Q :
  hProp P -> hProp Q -> ~ (P /\ Q) -> hProp (P \/ Q).
Proof.
  unfold hProp.
  intros hP hQ H [H1 | H1] [H2 | H2]; f_equal; firstorder; exfalso; tauto.
Qed.

Lemma Fext_hProp_neg P :
  Fext -> hProp (~ P).
Proof.
  intros fext H1 H2.
  eapply fext. intros x. exfalso. tauto.
Qed.

Lemma Fext_hProp_disj P :
  Fext -> hProp P -> hProp (P \/ ~ P).
Proof.
  intros. now eapply hProp_disj; [ | eapply Fext_hProp_neg | ].
Qed.

Lemma Fext_hProp_wdisj P :
  Fext -> hProp (~ P \/ ~~ P).
Proof.
  intros. now eapply Fext_hProp_disj; [ | eapply Fext_hProp_neg].
Qed.

Section CT_wrong.

  Variable ϕ : nat -> nat -> nat -> option nat.
  Variable Hϕ : forall c x, monotonic (ϕ c x).

  Definition CT_Sigma := forall f : nat -> nat, {c : nat | forall x, exists n, ϕ c x n = Some (f x) }.

  Lemma CT_Sigma_wrong : CT_Sigma -> Fext -> False.
  Proof.
    intros CT fext.
    eapply K_nat_undec. {
      right. exists ϕ. split; try eassumption.
      intros f. unshelve eexists.
      + intros x. destruct (CT (f x)) as [c]. exact c.
      + intros x y. cbn. destruct (CT (f x)) as [c Hc]; eauto.
    }
    exists (fun f => Nat.eqb (proj1_sig (CT f)) (proj1_sig (CT (fun _ => 0)))).
    intros f.
    destruct (PeanoNat.Nat.eqb_spec (` (CT f)) (` (CT (fun _ : nat => 0)))).
    - unfold reflects. intuition.
      destruct (CT f) as [cf Hf].
      destruct (CT (fun _ => 0)) as [cc Hc]. cbn in *. subst.
      destruct (Hf n), (Hc n).
      eapply monotonic_agnostic; eauto.
    - unfold reflects. intuition try congruence.
      assert (f = fun x => 0) as -> by now apply fext.
      congruence.
  Qed.

End CT_wrong.

(** ** Classical logical axioms  *)

Definition LEM := forall P, P \/ ~ P.
Definition DNE := forall P, ~~P -> P.
Definition DGP := forall P Q : Prop, (P -> Q) \/ (Q -> P).
Definition WLEM := forall P, ~~P \/ ~ P.

Definition IP := forall (P : Prop), forall p : nat -> Prop, (P -> exists n, p n) -> exists n, P -> p n.

Lemma LEM_to_DGP :
  LEM -> DGP.
Proof.
  intros H P Q.
  destruct (H P), (H Q); tauto.
Qed.

Lemma DGP_to_WLEM :
  DGP -> WLEM.
Proof.
  intros H P.
  destruct (H P (~ P)); tauto.
Qed.

Lemma LEM_to_IP : LEM -> IP.
Proof.
  intros H P p.
  destruct (H P) as [H0 | H0].
  - intros [n H1] % (fun H1 => H1 H0). eauto.
  - exists 0. tauto.
Qed.

(*

    LEM --> DGP --> WLEM
     |               |
     |               |
     v               v
    LPO     -->    WLPO   -->   LLPO
     ^               ^
     |               |
     v               v
  MP /\ WLPO     PFP /\ LLPO

     ^
     |

  MP /\ IP

 *)

Definition LPO := forall f : nat -> bool, (exists n, f n = true) \/ ~ (exists n, f n = true).
Definition WLPO := forall f : nat -> bool, (forall n, f n = false) \/ ~ (forall n, f n = false).

Lemma forall_neg_exists_iff (f : nat -> bool) :
  (forall n, f n = false) <-> ~ exists n, f n = true.
Proof.
  split.
  - intros H [n Hn]. rewrite H in Hn. congruence.
  - intros H n. destruct (f n) eqn:E; try reflexivity.
    destruct H. eauto.
Qed.

Lemma LEM_to_LPO : LEM -> LPO.
Proof.
  cbv. intuition.
Qed.

Lemma WLEM_to_WLPO : WLEM -> WLPO.
Proof.
  intros H f. rewrite forall_neg_exists_iff.
  edestruct H; eauto.
Qed.

Lemma LPO_to_WLPO : LPO -> WLPO.
Proof.
  intros H f. rewrite forall_neg_exists_iff.
  edestruct H; eauto.
Qed.

Definition LPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, p x \/ ~ p x.

Lemma LPO_semidecidable_iff :
  LPO <-> LPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. eapply H.
  - intros H f.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~ p x \/ ~~ p x.

Lemma WLPO_semidecidable_iff :
  WLPO <-> WLPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite <- forall_neg_exists_iff.
    eapply H.
  - intros H f.
    rewrite forall_neg_exists_iff.
    eapply (H unit (fun _ => exists n, f n = true)).
    exists (fun _ => f). cbv. intuition. econstructor.
Qed.

Definition WLPO_cosemidecidable := forall X (p : X -> Prop), co_semi_decidable p -> forall x, p x \/ ~ p x.

Lemma WLPO_cosemidecidable_iff :
  WLPO_cosemidecidable <-> WLPO_semidecidable.
Proof.
  split.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite <- forall_neg_exists_iff.
    eapply (H _ (fun x => forall n, f x n = false)).
    exists f. red. reflexivity.
  - intros H X p [f Hf] x. red in Hf.
    rewrite Hf. rewrite forall_neg_exists_iff.
    eapply (H _ (fun x => exists n, f x n = true)).
    exists f. intros x'. reflexivity.
Qed.

Definition CODING :=
  exists F : (nat -> bool) -> nat, forall f, F f = F (fun _ => false) <-> forall n, f n = false.

Lemma no_CODING :
  CODING -> decidable (compl K_nat_bool).
Proof.
  intros [F HF].
  exists (fun f => Nat.eqb (F f) (F (fun _ => false))).
  intros f. unfold compl, K_nat_bool. red. rewrite <- forall_neg_exists_iff.
  destruct (Nat.eqb_spec (F f) (F (fun _ => false))); rewrite <- HF.
  all: firstorder.
Qed.

Definition LLPO := forall f g : nat -> bool, ((exists n, f n = true) -> (exists n, g n = true)) \/ ((exists n, g n = true) -> (exists n, f n = true)).
Definition DM_Sigma_0_1 := forall f g : nat -> bool, ~ ((exists n, f n = true) /\ (exists n, g n = true)) -> ~ (exists n, f n = true) \/ ~ (exists n, g n = true).
Definition DGP_sdec := forall X (p : X -> Prop), semi_decidable p -> forall x y, (p x -> p y) \/ (p y -> p x).
Definition DM_sdec := forall X (p q : X -> Prop), semi_decidable p -> semi_decidable q -> forall x, ~ (p x /\ q x) -> ~ p x \/ ~ q x.
Definition LLPO_split := forall f : nat -> bool, (forall n m, f n = true -> f m = true -> n = m) -> (forall n, f (2 * n) = false) \/ (forall n, f (1 + 2 * n) = false).

Lemma LLPO_to_DM_Sigma_0_1 :
  LLPO -> DM_Sigma_0_1.
Proof.
  intros H f g Hfg.
  destruct (H f g); tauto.
Qed.

Lemma LLPO_iff_DGP_sdec :
  LLPO <-> DGP_sdec.
Proof.
  split.
  - intros H X p [f Hf] x y.
    unfold semi_decider in *.
    rewrite !Hf. eapply H.
  - intros H f g.
    unshelve eapply (H bool (fun b => if b then exists n, f n = true else exists n, g n = true) _ true false).
    + exists (fun b : bool => if b then f else g). red. intros []; reflexivity.
Qed.

Lemma DM_Sigma_0_1_iff_DM_sdec :
  DM_Sigma_0_1 <-> DM_sdec.
Proof.
  split.
  - intros H X p q [f Hf] [g Hg] x.
    unfold semi_decider in *.
    rewrite Hf, Hg. eapply H.
  - intros H f g Hfg.
    eapply (H unit (fun _ => exists n, f n = true) (fun _ => exists n, g n = true)).
    + exists (fun _ => f). red. reflexivity.
    + exists (fun _ => g). red. reflexivity.
    + econstructor.
    + eassumption.
Qed.

Lemma neg_neg_XM P :
  ~~ (P \/ ~ P).
Proof.
  tauto.
Qed.

Lemma DM_Sigma_0_1_iff_totality :
  DM_Sigma_0_1 <-> (forall X (R : X -> bool -> Prop), co_semi_decidable (curry R) -> forall n, ~~ (exists b, R n b) -> exists b, R n b).
Proof.
  split.
  - intros H X R [f Hf'] n.
    assert (Hf : forall n b, R n b <-> forall m, f (n, b) m = false) by (intros; eapply (Hf' (_, b))).
    setoid_rewrite Hf. clear - H. intros Hb.
    destruct (H (f (n, true)) (f (n, false))) as [H1 | H1].
    + intros [ [n1 ?] [n2 ?]]. eapply Hb. intros [[] ?]; congruence.
    + exists true. now eapply forall_neg_exists_iff.
    + exists false. now eapply forall_neg_exists_iff.
  - intros H f g Hfg.
    edestruct (H nat (fun _ b => if b then forall n, f n = false else forall n, g n = false)) with (n := 0) as [[] H1].
    + exists (fun '(n,b) => if b : bool then f else g). now intros (n, []).
    + intros H0. eapply (neg_neg_XM (exists n, f n = true)). intros [H1 | H1].
      * eapply (neg_neg_XM (exists n, g n = true)). intros [H2 | H2].
        -- eauto.
        -- eapply H0. exists false. now eapply forall_neg_exists_iff.
      * eapply H0. exists true. now eapply forall_neg_exists_iff.
    + left. now eapply forall_neg_exists_iff.
    + right. now eapply forall_neg_exists_iff.
Qed.

Lemma DM_Sigma_0_1_to_LLPO_split :
  DM_Sigma_0_1 -> LLPO_split.
Proof.
  intros H f Huni.
  destruct (H (fun n => f (2 * n)) (fun n => (f (1 + 2 * n)))).
  - intros [[n Hn] [m Hm]].
    eapply Huni in Hn; eauto. lia.
  - left. now rewrite forall_neg_exists_iff.
  - right. now rewrite forall_neg_exists_iff.
Qed.

Lemma dec_bounded_quant P n :
  (forall m, m <= n -> P m \/ ~ P m) -> (forall m, m <= n -> ~ P m) \/ exists m, m <= n /\ P m.
Proof.
  intros H.
  induction n.
  - destruct (H 0 (Nat.le_refl 0)).
    + right. exists 0. split. lia. eauto.
    + left. intros m Hm. enough (m = 0) by now subst. lia.
  - destruct IHn as [H1 | [m [Hle Hm]]].
    + intros. eapply H. lia.
    + destruct (H (S n) (Nat.le_refl _)).
      * right. eauto.
      * left. intros m [Hle |  ->] % le_lt_or_eq; eauto.
        eapply H1. lia.
    + right. exists m. split. lia. eassumption.
Qed.

Lemma least_ex (P : nat -> Prop) n : P n -> (forall m, m < n -> P m \/~ P m) -> exists n, P n /\ forall m, P m -> m >= n.
Proof.
  induction n using lt_wf_rec.
  intros Hn Hlt.
  destruct n.
  - exists 0. split. eauto. intros. lia.
  - edestruct dec_bounded_quant with (n := n).
    + intros. eapply (Hlt m). lia.
    + exists (S n). split. eauto. intros.
      destruct (le_lt_dec (S n) m); eauto. eapply H0 in H1; lia.
    + destruct H0 as (m & Hle & Hm).
      eapply (H m).
      * lia.
      * eassumption.
      * intros. eapply Hlt. lia.
Qed.

Lemma LLPO_split_to_LLPO :
  LLPO_split -> LLPO.
Proof.
  intros H f g.
  pose (alpha := (fun n => if n `mod` 2 =? 0 then f (n `div` 2) else g (n `div` 2))).
  pose (alpha' n := alpha n && forallb negb (map alpha (seq 0 n))).
  destruct (H alpha') as [H0 | H0].
  - intros n m [Ha1 Ha2] % andb_true_iff [Ha3 Ha4] % andb_true_iff.
    destruct (lt_eq_lt_dec n m) as [ [Hl | ] | Hl]; eauto.
    + rewrite forallb_forall in Ha4.
      setoid_rewrite in_map_iff in Ha4.
      setoid_rewrite in_seq in Ha4.
      enough (false = true) by congruence.
      eapply (Ha4 true). cbn. exists n. repeat split; eauto with arith.
    + rewrite forallb_forall in Ha2.
      setoid_rewrite in_map_iff in Ha2.
      setoid_rewrite in_seq in Ha2.
      enough (false = true) by congruence.
      eapply (Ha2 true). cbn. exists m. repeat split; eauto with arith.
  - left. intros [m Hm].
    destruct (least_ex (fun n => f n = true) _ Hm) as [n [Hn Hle]].
    { intros x. destruct (f x); firstorder congruence. }
    clear m Hm.
    assert (alpha (n * 2) = true). {
      unfold alpha. rewrite Nat.mod_mul. rewrite Nat.eqb_refl.
      rewrite Nat.div_mul. eauto. lia. lia.
    }
    destruct (dec_bounded_quant (fun n => g n = true) n).
    + intros m ?; destruct (g m); firstorder congruence.
    + exfalso. enough (alpha' (2 * n) = true). rewrite H0 in H3. congruence.
      rewrite mult_comm. unfold alpha'.
      eapply andb_true_iff. split. eauto.
      eapply forallb_forall.
      intros b. rewrite in_map_iff. setoid_rewrite in_seq.
      intros [k [H3 [_ H4] ]]. destruct b; try reflexivity.
      unfold alpha in H3.
      exfalso. destruct (k `mod` 2) eqn:Em.
      * cbn [Nat.eqb] in H3. eapply Hle in H3. cbn in H4.
        pose proof (Nat.div_lt_upper_bound k 2 n).
        lia.
      * cbn [Nat.eqb] in H3. eapply H2 in H3. lia.
        eapply Nat.div_le_upper_bound. lia. lia.
    + firstorder.
  - right. intros [m Hm].
    destruct (least_ex (fun n => g n = true) _ Hm) as [n [Hn Hle]].
    { intros x. destruct (g x); firstorder congruence. }
    clear m Hm.
    assert (alpha (1 + n * 2) = true). {
      unfold alpha. rewrite Nat.mod_add; try lia.
      change (1 `mod` 2 =? 0) with false. hnf.
      rewrite Nat.div_add. cbn. eauto. lia.
    }
    destruct (dec_bounded_quant (fun n => f n = true) (S n)).
    + intros m ?; destruct (f m); firstorder congruence.
    + exfalso. enough (H3 : alpha' (1 + 2 * n) = true). rewrite H0 in H3. congruence.
      rewrite mult_comm. unfold alpha'.
      eapply andb_true_iff. split. eauto.
      eapply forallb_forall.
      intros b. rewrite in_map_iff. setoid_rewrite in_seq.
      intros [k [H3 [_ H4] ]]. destruct b; try reflexivity.
      unfold alpha in H3.
      exfalso. destruct (k `mod` 2) eqn:Em.
      * cbn [Nat.eqb] in H3. eapply H2 in H3. cbn in H4. eauto.
        eapply Nat.div_le_upper_bound. lia. lia.
      * cbn [Nat.eqb] in H3. eapply Hle in H3. cbn in H4.
        rewrite Nat.mod_eq in Em; lia.
    + firstorder.
Qed.

Definition PFP := forall f : nat -> bool, exists g : nat -> bool, (forall n, f n = false) <-> exists n, g n = true.

Lemma WLPO_PFP_LLPO_iff :
  WLPO <-> PFP /\ LLPO.
Proof.
  split.
  - intros H. split.
    + intros f. destruct (H f).
      * exists (fun _ => true).
        split.
        -- now exists 0.
        -- eauto.
      * exists (fun _ => false).
        split.
        -- tauto.
        -- intros [? [=]].
    + eapply LLPO_split_to_LLPO, DM_Sigma_0_1_to_LLPO_split.
      intros f g Hfg.
      destruct (H f).
      * left. firstorder congruence.
      * destruct (H g).
        -- right. firstorder congruence.
        -- left. intros Hf.
           assert (H2 : ~~ ((exists n, g n = true) \/ ~ (exists n, g n = true))) by tauto.
           eapply H2. intros [Hg | Hg].
           now eapply Hfg. now rewrite <- forall_neg_exists_iff in Hg.
  - intros [PFP LLPO % LLPO_to_DM_Sigma_0_1] f.
    destruct (PFP f) as [g Hg].
    destruct (LLPO f g).
    + rewrite <- Hg. intros [[n Hn] H]. rewrite H in Hn. congruence.
    + left. now rewrite forall_neg_exists_iff.
    + right. now rewrite <- Hg in H.
Qed.

Definition KS := forall P, exists f : nat -> bool, P <-> exists n, f n = true.

Lemma LEM_to_KS :
  LEM -> KS.
Proof.
  intros xm P.
  destruct (xm P) as [H | H].
  - exists (fun _ => true). firstorder. econstructor.
  - exists (fun _ => false). firstorder.
Qed.

Lemma KS_LPO_to_LEM :
  KS -> LPO -> LEM.
Proof.
  intros ks lpo P.
  destruct (ks P) as [f ->].
  eapply lpo.
Qed.

Lemma KS_WLPO_to_WLEM :
  KS -> LPO -> LEM.
Proof.
  intros ks lpo P.
  destruct (ks P) as [f ->].
  eapply lpo.
Qed.

Lemma KS_LLPO_to_DGP :
  KS -> LLPO -> DGP.
Proof.
  intros ks lpo P Q.
  destruct (ks P) as [f ->].
  destruct (ks Q) as [g ->].
  eapply lpo.
Qed.

(** ** Axioms of russian constructivism  *)

Definition MP := forall f : nat -> bool, ~~ (exists n, f n = true) -> exists n, f n = true.

Definition MP_semidecidable := forall X (p : X -> Prop), semi_decidable p -> forall x, ~~ p x -> p x.
Definition Post_logical := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> forall x, p x \/ ~ p x.
Definition Post := forall X (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> decidable p.

Lemma LPO_MP_WLPO_iff :
  LPO <-> MP /\ WLPO.
Proof.
  split.
  - intros H. split.
    + intros f Hf. destruct (H f); tauto.
    + intros f. rewrite forall_neg_exists_iff. destruct (H f); tauto.
  - intros [MP WLPO] f.
    destruct (WLPO f).
    + right. now rewrite <- forall_neg_exists_iff.
    + left. eapply MP. now rewrite <- forall_neg_exists_iff.
Qed.

Lemma MP_IP_LPO : IP -> MP -> LPO.
Proof.
  intros IP MP f.
  assert (exists n, forall k, f k = true -> f n = true) as [n Hn].
  - specialize (MP f). apply IP in MP as [n Hn].
    exists n. intros k H. apply Hn. intros H'. apply H'. now exists k.
  - destruct (f n) eqn:E.
    + eauto.
    + right. intros [m Hm].
      specialize (Hn m Hm). congruence.
Qed.

Lemma MP_to_MP_semidecidable :
  MP -> MP_semidecidable.
Proof.
  intros H X p [f Hf] x. red in Hf.
  rewrite Hf. eapply H.
Qed.

Definition MP_semidecidable_ex := forall (p : nat -> Prop), semi_decidable p -> ~~ (exists x, p x) -> exists x, p x.

Lemma MP_semidecidable_to_MP_semidecidable_ex :
  MP_semidecidable -> MP_semidecidable_ex.
Proof.
  intros mp p [f Hf]. red in Hf. setoid_rewrite Hf.
  eapply (mp unit (fun _ => exists x n, f x n = true)).
  exists (fun _ => fun! ⟨x,n⟩ => f x n). intros _.
  split.
  - intros (x & n & Hxn). exists ⟨x,n⟩. now rewrite embedP.
  - intros (xn & Hxn). destruct (unembed xn) as [x n]. eauto.
  - exact tt.
Qed.

Lemma MP_semidecidable_ex_to_MP_semidecidable :
  MP_semidecidable_ex -> MP_semidecidable.
Proof.
  intros mp X p [f Hf] x. red in Hf. setoid_rewrite Hf.
  eapply mp. eapply decidable_semi_decidable.
  exists (fun x0 => f x x0). intros ?. red. reflexivity.
Qed.

Lemma MP_semidecidable_nat_to_MP_semidecidable :
  (forall p : nat -> Prop, semi_decidable p -> forall x, ~~ p x -> p x) -> MP_semidecidable.
Proof.
  intros mp. eapply MP_semidecidable_ex_to_MP_semidecidable.
  intros p [f Hf]. red in Hf. setoid_rewrite Hf.
  eapply (mp (fun _ => exists x n, f x n = true)).
  exists (fun _ => fun! ⟨x,n⟩ => f x n). intros _.
  split.
  - intros (x & n & Hxn). exists ⟨x,n⟩. now rewrite embedP.
  - intros (xn & Hxn). destruct (unembed xn) as [x n]. eauto.
  - exact 0.
Qed.

Lemma MP_semidecidable_to_Post_logical :
  MP_semidecidable -> Post_logical.
Proof.
  intros H X p Hp Hcp x. pattern x.
  eapply H.
  - now eapply semi_decidable_or.
  - tauto.
Qed
.
Definition MP_semidecidable_ex_enumerable := forall X (p : X -> Prop), enumerable p -> ~~ (exists x, p x) -> exists x, p x.

Lemma MP_bla :
  MP_semidecidable_ex -> MP_semidecidable_ex_enumerable.
Proof.
  intros mp X p [f Hf]. red in Hf.
  setoid_rewrite Hf. intros H.
  destruct (mp (fun n => f n <> None)) as [n Hn].
  - eapply decidable_semi_decidable. eapply decidable_iff.
    econstructor. intros n. destruct (f n); firstorder.
  - intros HH. apply H. intros (x & n & HHH). eapply HH. exists n. congruence.
  - destruct (f n) eqn:E; try congruence. now exists x, n.
Qed.

Lemma MP_blub :
  MP_semidecidable_ex_enumerable -> MP_semidecidable_ex.
Proof.
  intros mp p Hp.
  eapply mp. eapply semi_decidable_enumerable; eauto.
Qed.

Lemma Post_logical_to_Post :
  Post_logical -> Post.
Proof.
  intros H X p Hp Hcp.
  destruct (sdec_compute_lor Hp Hcp) as [f Hf].
  - eapply H; eauto.
  - exists f. intros x. red. specialize (Hf x). destruct (f x); firstorder congruence.
Qed.

Lemma Post_nempty_to_MP {X} (x0 : X) :
  (forall (p : X -> Prop), semi_decidable p -> semi_decidable (compl p) -> decidable p) -> MP.
Proof.
  intros H f Hf.
  destruct (H (fun _ => exists n, f n = true)) as [d Hd].
  - exists (fun _ => f). now intros x.
  - exists (fun _ _ => false). firstorder.
  - destruct (decider_decide Hd x0); tauto.
Qed.

Lemma Post_to_MP :
  Post -> MP.
Proof.
  intros H. apply (Post_nempty_to_MP tt). apply H.
Qed.

Lemma semi_decidable_ext {X} (p q : X -> Prop) :
  p ≡{X -> Prop} q -> semi_decidable p -> semi_decidable q.
Proof.
  intros H [f Hf]. exists f. intros x. cbv -[iff] in H.
  rewrite <- H. eapply Hf.
Qed.

Lemma MP_iff_sdec_weak_total :
  MP_semidecidable <-> (forall X (R : X -> bool -> Prop), semi_decidable (curry R) -> forall x, ~~ (exists b, R x b) -> exists b, R x b).
Proof.
  split.
  - intros H X R [f Hf] x Hx.
    eapply H with (x := x).
    eapply semi_decidable_ext.
    2: eapply (@semi_decidable_or _ (fun x => R x true) (fun x => R x false)).
    + clear. intros x. split. firstorder. intros [[] ?]; firstorder.
    + exists (fun x n => f (x, true) n). intros x0. red in Hf.
      now rewrite (Hf (x0, true)).
    + exists (fun x n => f (x, false) n). intros x0. red in Hf.
      now rewrite (Hf (x0, false)).
    + eassumption.
  - intros H X p [f Hf] x Hx.
    edestruct (H X (fun x b => p x)).
    + exists (fun '(x, b) n => f x n). intros (?, b). cbn. eapply Hf.
    + intros Hp. eapply Hx. intros Hpx. eapply Hp. exists true. eassumption.
    + eassumption.
Qed.

Lemma MP_cosdec_to_sdec :
  MP ->
  (forall X (p : X -> Prop), co_semi_decidable p -> semi_decidable (compl p)).
Proof.
  intros mp X p [f Hf]. exists f. unfold semi_decider, compl.
  intros x. red in Hf. rewrite Hf. rewrite forall_neg_exists_iff.
  split; eauto.
Qed.

Lemma MP_partial_to_MP {Part : partiality} X (x0 : X) :
  (forall x : part X, ~~ ter x -> ter x) -> MP.
Proof.
  intros mp f Hf.
  destruct (mp (bind (mu_tot f) (fun _ => ret x0))) as [? H].
  intros H. apply Hf. intros [n [m Hm] % mu_tot_ter].
  apply H. exists x0.
  eapply bind_hasvalue.
  exists m. split; eauto. eapply ret_hasvalue.
  eapply bind_hasvalue in H as (? & [] % mu_tot_hasvalue & ?).
  eauto.
Qed.

Lemma MP_to_MP_partial {Part : partiality} :
  MP -> (forall X, forall x : part X, ~~ ter x -> ter x).
Proof.
  intros MP X x.
  assert (ter x <-> exists n, (if seval x n is Some x then true else false) = true). {
    split.
    - intros [a [n H] % seval_hasvalue]. exists n. now rewrite H.
    - intros [n H]. destruct seval as [ a | ] eqn:E; try congruence.
      exists a. eapply seval_hasvalue. eauto.
  }
  rewrite H.
  eapply MP.
Qed.

Lemma DNE_sdec_to_cosdec :
  DNE ->
  (forall X (p : X -> Prop), semi_decidable (compl p) -> co_semi_decidable p).
Proof.
  intros mp X p [f Hf]. exists f. unfold semi_decider, compl in *.
  intros x. rewrite forall_neg_exists_iff. rewrite <- Hf.
  split; eauto. eapply mp.
Qed.

Require Import Undecidability.Shared.FinitenessFacts.

Require Import Undecidability.Shared.Dec.

Lemma semi_decidable_generative (p : nat -> Prop) :
  MP -> semi_decidable p ->
  ~ exhaustible p -> generative p.
Proof.
  intros mp % MP_to_MP_semidecidable % MP_semidecidable_to_MP_semidecidable_ex Hs Hl l.
  eapply mp.
  - eapply semi_decidable_and. eauto. eapply decidable_semi_decidable, decidable_complement, listable_decidable.
    eapply discrete_nat. exists l. red. reflexivity.
  - apply non_finite_spec; eauto. intros. destruct (Nat.eqb_spec x1 x2); firstorder.
Qed.

(*
Lemma rev :
  (forall X (p : X -> Prop), discrete X -> semi_decidable p -> ~ exhaustible p -> generative p) ->
  MP_semidecidable.
Proof.
  intros H X p Hp x Hx.
  destruct (P_inf_spec (p x)) as [_ [HH | HH]]; try tauto.
  eapply unbounded_inhabited, generative_unbounded, H.
  - exact discrete_nat.
  - eapply decidable_semi_decidable. exists Nat.even.
    intros n. red. unfold P_inf. destruct Nat.even; try now firstorder congruence.
*)

(** ** Choice axioms *)

Definition AC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC := forall X Y, AC_on X Y.

Definition UNIF_on X Y := forall R : X -> Y -> Prop,
  (forall x, exists y, R x y) -> exists R' : X -> Y -> Prop, (forall x y, R' x y -> R x y) /\ (forall x, exists! y, R' x y).

Definition AUC_on X Y :=
  forall R : X -> Y -> Prop, (forall x, exists! y, R x y) -> exists f : X -> Y, forall x, R x (f x).

Definition AC_0_0 :=
  AC_on nat nat.

Definition AC_1_0 :=
  AC_on (nat -> nat) nat.

Definition ADC_on X := forall R : X -> X -> Prop, forall x0, (forall x, exists x', R x x') -> exists f : nat -> X, f 0 = x0 /\ forall n, R (f n) (f (S n)).

Definition ADC := forall X, ADC_on X.
Definition ACC := forall X, AC_on nat X.

Lemma total_list {X Y} {R : X -> Y -> Prop} L :
  (forall x, exists y, R x y) -> exists L', Forall2 R L L'.
Proof.
  intros HTot. induction L as [ | x L [L' IH]].
  - exists []. econstructor.
  - destruct (HTot x) as [y H]. exists (y :: L').
    now econstructor.
Qed.

Lemma AC_rel_to_ADC : forall X, AC_on X X -> ADC_on X.
Proof.
  intros X C R x0 Htot.
  eapply C in Htot as [f].
  exists (fun n => Nat.iter n f x0).
  split. reflexivity. intros n. eapply H.
Qed.

Lemma AC_on_to_AUC_on : forall X Y, AC_on X Y -> AUC_on X Y.
Proof.
  intros X Y C R H. eapply C. firstorder.
Qed.

Goal AC -> ADC.
Proof.
  intros ? X Inh.
  eapply AC_rel_to_ADC, H.
Qed.

Goal ADC -> ACC.
Proof.
  intros C X R Htot.
  destruct (Htot 0) as [y0 Hy0].
  unshelve specialize (C (∑ '(n, x), R n x) (fun '(exist _  (n, x) H) '(exist _ (m, y) H2) => m = S n)) as [f].
  - eexists (_, _). eauto.
  - intros [(n, x) H]. destruct (Htot (S n)) as [y Hy]. now exists (exist _ (S n, y) Hy).
  - destruct H as [H0 H].
    pose (N n := fst (proj1_sig (f n))).
    pose (s n := snd (proj1_sig (f n))).
    assert (HN : forall n, N (S n) = S (N n)). {
      intros n. cbv.
      pose proof (H (S n)) as Hsn.
      pose proof (H n) as Hn.
      destruct (f n) as [(m', y') H'].
      destruct (f (S n)) as [(m, y) Hmy]. eassumption.
    }
    assert (HN0 : forall n, N n = N 0 + n) by (induction n; rewrite ?HN; lia).
    assert (H1 : forall n, R (N n) (s n)). {
      intros n. unfold N, s.
      specialize (H n).
      destruct (f n) as [(m, y) Hmy]. exact Hmy.
    }
    pose proof (total_list (seq 0 (N 0)) Htot) as [L' HL'].
    exists (fun n => if le_lt_dec (N 0) n is left _ then s (n - N 0) else (nth n L' (s 0))). intros n.
    destruct (le_lt_dec (N 0) n) as [Hl | Hl].
    + specialize (H1 (n - N 0)). rewrite HN0 in H1.
      now replace n with (N 0 + (n - N 0)) at 1 by lia.
    + rewrite nth_lookup.
      destruct (L' !! n) as [x|] eqn:E.
      * cbn.
        edestruct (Forall2_lookup_l R (seq 0 (N 0)) L') as [? []]. eassumption.
        rewrite lookup_seq; eauto.
        rewrite E in H2. inv H2. eassumption.
      * eapply lookup_ge_None in E. erewrite <- Forall2_length in E; eauto.
        rewrite seq_length in E. lia.
Qed.

Goal ACC -> AC_0_0.
Proof.
  unfold ACC, AC_0_0.
  intros H. eapply H.
Qed.

Lemma AC_1_0_to_AC_0_0 : AC_1_0 -> AC_0_0.
Proof.
  intros C R Htot.
  destruct (C (fun g x => R (g 0) x)) as [f].
  - intros g. eapply Htot.
  - exists (fun x => f (fun _ => x)).
    intros x. eapply (H (fun _ => x)).
Qed.

Lemma AC_0_0_to_AC_nat_bool : AC_0_0 -> AC_on nat bool.
Proof.
  intros C R Htot.
  destruct (C (fun n m => R n (Nat.eqb m 0))) as [f].
  - intros x. destruct (Htot x) as [ [] ].
    + exists 0. firstorder.
    + exists 1. firstorder.
  - eexists. eapply H.
Qed.

Lemma UNIFx_char X Y :
  AC_on X Y <-> AUC_on X Y /\ UNIF_on X Y.
Proof.
  split. 1: intros C; split.
  - intros R Htot. edestruct (C R) as [f Hf]; firstorder.
  - intros R [f Hf] % C. exists (fun x y => f x = y). now firstorder subst.
  - intros [C1 C2] R Htot.
    specialize (C2 _ Htot) as (R' & H1 & H2).
    destruct (C1 _ H2) as [f Hf]. eauto.
Qed.

Lemma Diaconescu :
  (forall X Y, AC_on X Y) -> Fext -> Pext -> LEM.
Proof.
  intros C fext pext P.
  pose (U (x : bool) := x = true \/ P).
  pose (V (x : bool) := x = false \/ P).
  destruct (C ({ p : bool -> Prop | p = U \/ p = V}) bool (fun p b => (proj1_sig p b))) as [f Hf].
  - intros (p & [-> | ->]); cbn.
    + exists true. now left.
    + exists false. now left.
  - pose proof (Hf (exist _ U (or_introl eq_refl))) as H1.
    pose proof (Hf (exist _ V (or_intror eq_refl))) as H2. cbn in *.
    assert (f (exist _ U (or_introl eq_refl)) <> f (exist _ V (or_intror eq_refl)) \/ P) as [H3 | H3]; eauto.
    {
      destruct H1 as [H1 | H1], H2 as [H2 | H2]; eauto.
      firstorder congruence.
    }
    right. intros H.
    assert (U = V) as ->. {
      eapply fext. intros b. eapply pext.
      unfold U, V. intuition.
    }
    eapply H3. repeat f_equal.
    eapply (Pext_to_PI pext).
Qed.

(* *** Compatibility  *)
(*
Lemma AC_1_0_Fext :
  AC_1_0 -> Fext -> EA -> decidable (compl K_nat_nat).
Proof.
  intros C Fext EA.
  pose proof (fun f => enumerable_code EA _ (enumerable_graph' f)).
  eapply C in H as [code Hcode].
  exists (fun f => Nat.eqb (code f) (code (fun _ => 0))).
  eapply Proper_decider. intros ?. reflexivity.
  eapply (K_nat_equiv).
  intros f. split; rewrite NPeano.Nat.eqb_eq.
  - intros E.
    eapply f_equal, Fext, E.
  - intros E n.
    generalize (Hcode f), (Hcode (fun _ => 0)).
    rewrite E. clear E.
    intros Hf H.
    pose proof(enumerator_ext Hf H (ltac:(reflexivity)) ⟨ n, f n ⟩) as E.
    destruct E as [[x E%(f_equal unembed)] _]; eauto.
    rewrite !embedP in E. now inv E.
Qed. *)

Lemma AUC_to_dec (p : nat -> Prop) :
  AUC_on nat bool -> (forall n, p n \/ ~ p n) -> decidable p.
Proof.
  intros C Hp.
  destruct (C (fun n b => (p n /\ b = true) \/ (~ p n /\ b = false))) as [f Hf].
  - intros n. destruct (Hp n) as [H | H].
    + exists true.  split. left. eauto. intros [];  firstorder congruence. congruence.
    + exists false. split. right. eauto. intros []; firstorder congruence. congruence.
  - exists f. intros n. destruct (Hf n) as [[H ->] | [H ->]]; firstorder congruence. congruence.
Qed.

Lemma AC_0_0_LPO_incompat'  :
  AUC_on nat bool -> WLPO -> EPF_bool -> forall p : nat -> Prop,
    semi_decidable p -> decidable (compl p).
Proof.
  intros C LPO % WLPO_semidecidable_iff EPF p Hp.
  eapply AUC_to_dec; eauto.
Qed.

Lemma AC_0_0_LPO_incompat :
  AUC_on nat bool -> WLPO -> EPF_bool -> False.
Proof.
  intros C LPO EPF_bool.
  destruct (EPF_SCT_halting) as (K & H1 & H2 & H3 & H4); [eauto|].
  eapply H4. eapply AC_0_0_LPO_incompat'; eauto.
Qed.

Lemma AC_1_0_Fext_CODING :
  AC_1_0 -> Fext -> SCT -> CODING.
Proof.
  intros C Fext (ϕ & Hmono & Hϕ).
  assert (forall f : nat -> nat, exists c, forall x, exists n, ϕ c x n = Some (f x)) as [F HF] % C. {
    intros f. destruct (Hϕ (fun _ => f)) as [c Hc].
    eexists. eapply (Hc 0).
  }
  exists (fun (f : nat -> bool) => F (fun x : nat => if f x then 0 else 1)).
  intros f. split.
  + intros H x.
    pose proof (HF (λ _ : nat, 1) x) as [n1 Hn1]. rewrite <- H in Hn1.
    pose proof (HF (λ x : nat, if f x then 0 else 1) x) as [n2 Hn2].
    eapply monotonic_agnostic in Hn1. 2: eapply Hmono.
    eapply Hn1 in Hn2. destruct (f x); congruence.
  + intros H2. f_equal. eapply Fext. intros x. rewrite H2. reflexivity.
Qed.

Lemma AC_1_0_Fext_incompat :
  AC_1_0 -> Fext -> SCT -> False.
Proof.
  intros C funext ct.
  eapply K_nat_bool_undec; [ eauto | ].
  now eapply no_CODING, AC_1_0_Fext_CODING.
Qed.

(** ** Brouwer's intuitionism *)

Definition WC_N :=
  forall R : (nat -> nat) -> nat -> Prop,
    (forall α, exists x, R α x) -> forall α, exists L, exists y, forall β, map α L = map β L -> R β y.

Lemma max_list_with_spec' {X} (l : list X) f :
  l <> nil -> In (max_list_with f l) (map f l).
Proof.
  destruct l as [ | x l] using rev_ind; try congruence.
  clear IHl. intros _. induction l; cbn in *.
  - lia.
  - destruct (Nat.max_dec (f a) (max_list_with f (l ++ [x]))) as [H1 | H1].
    + now left.
    + right. rewrite H1 in *. eauto.
Qed.

Lemma max_list_spec' l :
  l <> nil -> In (max_list l) l.
Proof.
  intros H % (max_list_with_spec' _ id).
  now rewrite map_id in H.
Qed.

Lemma max_list_with_spec {X} (x : X) l f :
  In x l -> f x <= max_list_with f l.
Proof.
  intros H.
  induction l in x, H |- *.
  - inv H.
  - inv H; cbn.
    + lia.
    + eapply IHl in H0. lia.
Qed.

Lemma max_list_spec x l :
  In x l -> x <= max_list l.
Proof.
  eapply (max_list_with_spec x l id).
Qed.

Lemma WC_N_CT_inc :
  WC_N -> SCT -> False.
Proof.
  intros WC [ϕ [Hm CT]].
  edestruct (WC (fun α c => forall x, exists n, ϕ c x n = Some (α x))) with (α := fun x : nat => 0) as [L [c H]].
  - intros f. destruct (CT (fun _ => f)) as [c]. eexists. eapply (H 0).
  - unshelve epose proof (H (fun x => if ListDec.In_dec Nat.eq_dec x L is left _ then 0 else 1) _).
    + eapply map_ext_in. intros a Ha. now destruct List.In_dec.
    + destruct (H0 (1 + max_list L)).
      destruct (H _ eq_refl (1 + max_list L)).
      enough (1 = 0) by lia.
      eapply monotonic_agnostic.
      * eapply Hm.
      * rewrite H1. destruct ListDec.In_dec as [HH | HH].
        -- eapply max_list_spec in HH. lia.
        -- reflexivity.
      * eauto.
Qed.

Definition Cont := forall F : (nat -> nat) -> nat, forall f, exists L, forall g, map f L = map g L -> F f = F g.

Lemma WC_N_to_Cont :
  WC_N -> Cont.
Proof.
  intros H F f.
  edestruct (H (fun f n => F f = n)) as (L & c & Hc).
  + eauto.
  + exists L. intros g Hg.
    eapply Hc in Hg. rewrite Hg.
    now eapply Hc.
Qed.

Definition ADC_on' X := forall R : list X -> X -> Prop, (forall x, exists x', R x x') -> exists f : nat -> X, forall n, R (map f (seq 0 n)) (f n).

Lemma ADC_on'_iff :
  AC_on nat bool -> ADC_on' bool.
Proof.
  intros C R Htot.
  assert (datatype (list bool)) as (G & F & HFG). {
      eapply enumerable_discrete_datatype; eauto.
      eapply discrete_iff. econstructor. exact _.
  }
  pose (F' n := match F n with Some u => u | _ => [] end).
  destruct (C (fun n b => R (F' n) b)) as [f Hf]; eauto.
  pose (f' := fix f' n := match n with 0 => [] | S n => f' n ++ [f (G (f' n))] end).
  assert (Hlen : forall n, length (f' n) = n) by (induction n; cbn; rewrite ?app_length; cbn; lia).
  exists (fun n => nth n (f' (S n)) false).
  cbn. intros n.
  rewrite app_nth2. 2: rewrite Hlen; lia.
  assert (n - length (f' n) = 0) as -> by (rewrite Hlen; lia). cbn.
  specialize (Hf (G (f' n))).
  enough ((F' (G (f' n))) = map (λ n0 : nat, nth n0 (f' n0 ++ [f (G (f' n0))]) false) (seq 0 n)) by congruence.
  unfold F'. rewrite HFG.
  erewrite map_ext. 2:{
    intros a. rewrite app_nth2. 2: rewrite Hlen; lia.
    assert (a - length (f' a) = 0) as -> by (rewrite Hlen; lia). cbn. reflexivity.
  }
  clear.
  induction n.
  - reflexivity.
  - cbn [f']. replace (S n) with (n + 1) by lia.
    rewrite seq_app, map_app. cbn. congruence.
Qed.


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

 Iso-inserters in bicategories

 Contents
 1. Cones
 2. The universal mapping property
 3. The universal property gives an equivalence of categories
 4. Bicategories with iso-inserters
 5. Inserters are faithful
 6. Inserters are conservative

 ****************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.categories.CatIsoInserter.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms.

Local Open Scope cat.

Section IsoInserters.
  Context {B : bicat}
          {b₁ b₂ : B}
          {f g : b₁ --> b₂}.

  (**
   1. Cones
   *)
  Definition iso_inserter_cone
    : UU
    := ∑ (i : B)
         (m : i --> b₁),
       invertible_2cell (m · f) (m · g).

  Definition make_iso_inserter_cone
             (i : B)
             (m : i --> b₁)
             (α : invertible_2cell (m · f) (m · g))
    : iso_inserter_cone
    := i ,, m ,, α.

  Coercion iso_inserter_cone_ob
           (cone : iso_inserter_cone)
    : B
    := pr1 cone.

  Definition iso_inserter_cone_pr1
             (cone : iso_inserter_cone)
    : cone --> b₁
    := pr12 cone.

  Definition iso_inserter_cone_cell
             (cone : iso_inserter_cone)
    : invertible_2cell
        (iso_inserter_cone_pr1 cone · f)
        (iso_inserter_cone_pr1 cone · g)
    := pr22 cone.

  Definition iso_inserter_1cell
             (cone₁ cone₂ : iso_inserter_cone)
    : UU
    := ∑ (k : cone₁ --> cone₂)
         (α : invertible_2cell
                (k · iso_inserter_cone_pr1 cone₂)
                (iso_inserter_cone_pr1 cone₁)),
       (k ◃ iso_inserter_cone_cell cone₂)
       • lassociator _ _ _
       • (α ▹ g)
       =
       lassociator _ _ _
       • (α ▹ f)
       • iso_inserter_cone_cell cone₁.

  Definition make_iso_inserter_1cell
             {cone₁ cone₂ : iso_inserter_cone}
             (k : cone₁ --> cone₂)
             (α : invertible_2cell
                    (k · iso_inserter_cone_pr1 cone₂)
                    (iso_inserter_cone_pr1 cone₁))
             (p : (k ◃ iso_inserter_cone_cell cone₂)
                  • lassociator _ _ _
                  • (α ▹ g)
                  =
                  lassociator _ _ _
                  • (α ▹ f)
                  • iso_inserter_cone_cell cone₁)
    : iso_inserter_1cell cone₁ cone₂
    := k ,, α ,, p.

  Coercion iso_inserter_1cell_mor
           {cone₁ cone₂ : iso_inserter_cone}
           (u : iso_inserter_1cell cone₁ cone₂)
    : cone₁ --> cone₂
    := pr1 u.

  Definition iso_inserter_1cell_pr1
             {cone₁ cone₂ : iso_inserter_cone}
             (u : iso_inserter_1cell cone₁ cone₂)
    : invertible_2cell
        (u · iso_inserter_cone_pr1 cone₂)
        (iso_inserter_cone_pr1 cone₁)
    := pr12 u.

  Definition iso_inserter_1cell_cell
             {cone₁ cone₂ : iso_inserter_cone}
             (u : iso_inserter_1cell cone₁ cone₂)
    : (_ ◃ iso_inserter_cone_cell cone₂)
       • lassociator _ _ _
       • (iso_inserter_1cell_pr1 u ▹ g)
       =
       lassociator _ _ _
       • (iso_inserter_1cell_pr1 u ▹ f)
       • iso_inserter_cone_cell cone₁
    := pr22 u.

  Definition path_iso_inserter_1cell
             {cone₁ cone₂ : iso_inserter_cone}
             (φ ψ : iso_inserter_1cell cone₁ cone₂)
             (p₁ : pr1 φ = pr1 ψ)
             (p₂ : pr112 φ = (idtoiso_2_1 _ _ p₁ ▹ _) • pr112 ψ)
    : φ = ψ.
  Proof.
    induction φ as [ φ₁ [ φ₂ φ₃ ]].
    induction ψ as [ ψ₁ [ ψ₂ ψ₃ ]].
    cbn in *.
    induction p₁.
    apply maponpaths.
    use subtypePath.
    {
      intro.
      apply cellset_property.
    }
    cbn.
    use subtypePath.
    {
      intro.
      apply isaprop_is_invertible_2cell.
    }
    cbn in p₂.
    rewrite id2_rwhisker, id2_left in p₂.
    exact p₂.
  Qed.

  (**
   2. The universal mapping property
   *)
  Section UniversalMappingProperty.
    Context (cone : iso_inserter_cone).

    Definition has_iso_inserter_ump_1
      : UU
      := ∏ (other_cone : iso_inserter_cone),
         iso_inserter_1cell other_cone cone.

    Definition has_iso_inserter_ump_2
      : UU
      := ∏ (x : B)
           (u₁ u₂ : x --> cone)
           (α : u₁ · iso_inserter_cone_pr1 cone
                ==>
                u₂ · iso_inserter_cone_pr1 cone)
           (p : rassociator _ _ _
                • (u₁ ◃ iso_inserter_cone_cell cone)
                • lassociator _ _ _
                • (α ▹ g)
                =
                (α ▹ f)
                • rassociator _ _ _
                • (u₂ ◃ iso_inserter_cone_cell cone)
                • lassociator _ _ _),
         ∑ (ζ : u₁ ==> u₂),
         ζ ▹ iso_inserter_cone_pr1 cone = α.

    Definition has_iso_inserter_ump_eq
      : UU
      := ∏ (x : B)
           (u₁ u₂ : x --> cone)
           (α : u₁ · iso_inserter_cone_pr1 cone
                ==>
                u₂ · iso_inserter_cone_pr1 cone)
           (p : rassociator _ _ _
                • (u₁ ◃ iso_inserter_cone_cell cone)
                • lassociator _ _ _
                • (α ▹ g)
                =
                (α ▹ f)
                • rassociator _ _ _
                • (u₂ ◃ iso_inserter_cone_cell cone)
                • lassociator _ _ _)
           (φ₁ φ₂ : u₁ ==> u₂)
           (q₁ : φ₁ ▹ iso_inserter_cone_pr1 cone = α)
           (q₂ : φ₂ ▹ iso_inserter_cone_pr1 cone = α),
         φ₁ = φ₂.

    Definition has_iso_inserter_ump
      : UU
      := has_iso_inserter_ump_1 × has_iso_inserter_ump_2 × has_iso_inserter_ump_eq.
  End UniversalMappingProperty.

  Section Projections.
    Context {cone : iso_inserter_cone}
            (H : has_iso_inserter_ump cone).

    Definition iso_inserter_ump_mor
               {i : B}
               (m : i --> b₁)
               (α : invertible_2cell (m · f) (m · g))
      : i --> cone
      := pr1 H (make_iso_inserter_cone i m α).

    Definition iso_inserter_ump_mor_pr1
               {i : B}
               (m : i --> b₁)
               (α : invertible_2cell (m · f) (m · g))
      : invertible_2cell
          (iso_inserter_ump_mor m α · iso_inserter_cone_pr1 cone)
          m
      := iso_inserter_1cell_pr1 (pr1 H (make_iso_inserter_cone i m α)).

    Definition iso_inserter_ump_mor_cell
               {i : B}
               (m : i --> b₁)
               (α : invertible_2cell (m · f) (m · g))
      : (_ ◃ iso_inserter_cone_cell cone)
        • lassociator _ _ _
        • (iso_inserter_ump_mor_pr1 m α ▹ g)
        =
        lassociator _ _ _
        • (iso_inserter_ump_mor_pr1 m α ▹ f)
        • α
      := iso_inserter_1cell_cell (pr1 H (make_iso_inserter_cone i m α)).

    Definition iso_inserter_ump_cell
               {x : B}
               {u₁ u₂ : x --> cone}
               (α : u₁ · iso_inserter_cone_pr1 cone
                    ==>
                    u₂ · iso_inserter_cone_pr1 cone)
               (p : rassociator _ _ _
                    • (u₁ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _
                    • (α ▹ g)
                    =
                    (α ▹ f)
                    • rassociator _ _ _
                    • (u₂ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _)
      : u₁ ==> u₂
      := pr1 (pr12 H x u₁ u₂ α p).

    Definition iso_inserter_ump_cell_pr1
               {x : B}
               {u₁ u₂ : x --> cone}
               (α : u₁ · iso_inserter_cone_pr1 cone
                    ==>
                    u₂ · iso_inserter_cone_pr1 cone)
               (p : rassociator _ _ _
                    • (u₁ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _
                    • (α ▹ g)
                    =
                    (α ▹ f)
                    • rassociator _ _ _
                    • (u₂ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _)
      : iso_inserter_ump_cell α p ▹ iso_inserter_cone_pr1 cone = α
      := pr2 (pr12 H x u₁ u₂ α p).

    Definition iso_inserter_ump_eq
               {x : B}
               {u₁ u₂ : x --> cone}
               (α : u₁ · iso_inserter_cone_pr1 cone
                    ==>
                    u₂ · iso_inserter_cone_pr1 cone)
               (p : rassociator _ _ _
                    • (u₁ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _
                    • (α ▹ g)
                    =
                    (α ▹ f)
                    • rassociator _ _ _
                    • (u₂ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _)
               (φ₁ φ₂ : u₁ ==> u₂)
               (q₁ : φ₁ ▹ iso_inserter_cone_pr1 cone = α)
               (q₂ : φ₂ ▹ iso_inserter_cone_pr1 cone = α)
      : φ₁ = φ₂
      := pr22 H x u₁ u₂ α p φ₁ φ₂ q₁ q₂.

    Definition iso_inserter_ump_eq_alt
               {x : B}
               {u₁ u₂ : x --> cone}
               (φ₁ φ₂ : u₁ ==> u₂)
               (p : rassociator _ _ _
                    • (u₁ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _
                    • (φ₁ ▹ iso_inserter_cone_pr1 cone ▹ g)
                    =
                    (φ₁ ▹ iso_inserter_cone_pr1 cone ▹ f)
                    • rassociator _ _ _
                    • (u₂ ◃ iso_inserter_cone_cell cone)
                    • lassociator _ _ _)
               (q : φ₁ ▹ iso_inserter_cone_pr1 cone
                    =
                    φ₂ ▹ iso_inserter_cone_pr1 cone)
      : φ₁ = φ₂.
    Proof.
      use iso_inserter_ump_eq.
      - exact (φ₁ ▹ iso_inserter_cone_pr1 cone).
      - exact p.
      - apply idpath.
      - exact (!q).
    Qed.
  End Projections.

  Section Invertible2CellIso_inserterUMP.
    Context {cone : iso_inserter_cone}
            (H : has_iso_inserter_ump cone)
            {x : B}
            {u₁ u₂ : x --> cone}
            (α : u₁ · iso_inserter_cone_pr1 cone
                 ==>
                 u₂ · iso_inserter_cone_pr1 cone)
            (p : rassociator _ _ _
                 • (u₁ ◃ iso_inserter_cone_cell cone)
                 • lassociator _ _ _
                 • (α ▹ g)
                 =
                 (α ▹ f)
                 • rassociator _ _ _
                 • (u₂ ◃ iso_inserter_cone_cell cone)
                 • lassociator _ _ _)
            (Hα : is_invertible_2cell α).

    Local Lemma is_invertible_2cell_iso_inserter_ump_cell_inv_path
      : rassociator _ _ _
        • (u₂ ◃ iso_inserter_cone_cell cone)
        • lassociator _ _ _
        • (Hα ^-1 ▹ g)
        =
        (Hα ^-1 ▹ f)
        • rassociator _ _ _
        • (u₁ ◃ iso_inserter_cone_cell cone)
        • lassociator _ _ _.
    Proof.
      use vcomp_move_R_Mp ; [ is_iso | ].
      rewrite !vassocl.
      use vcomp_move_L_pM ; [ is_iso | ].
      cbn.
      rewrite !vassocr.
      exact (!p).
    Qed.

    Let inv : u₂ ==> u₁
      := iso_inserter_ump_cell
           H
           (Hα^-1)
           is_invertible_2cell_iso_inserter_ump_cell_inv_path.

    Local Lemma is_invertible_2cell_iso_inserter_ump_cell_inv_right
      : iso_inserter_ump_cell H α p • inv = id₂ _.
    Proof.
      use (iso_inserter_ump_eq_alt H).
      - rewrite <- !rwhisker_vcomp.
        rewrite !vassocr.
        unfold inv.
        rewrite !iso_inserter_ump_cell_pr1.
        rewrite rwhisker_vcomp.
        rewrite !vassocl.
        rewrite rwhisker_vcomp.
        rewrite !vcomp_rinv.
        rewrite !id2_rwhisker.
        rewrite id2_left, id2_right.
        apply idpath.
      - rewrite <- !rwhisker_vcomp.
        unfold inv.
        rewrite !iso_inserter_ump_cell_pr1.
        rewrite id2_rwhisker.
        apply vcomp_rinv.
    Qed.

    Local Lemma is_invertible_2cell_iso_inserter_ump_cell_inv_left
      : inv • iso_inserter_ump_cell H α p = id₂ _.
    Proof.
      use (iso_inserter_ump_eq_alt H).
      - rewrite <- !rwhisker_vcomp.
        rewrite !vassocr.
        unfold inv.
        rewrite !iso_inserter_ump_cell_pr1.
        rewrite rwhisker_vcomp.
        rewrite !vassocl.
        rewrite rwhisker_vcomp.
        rewrite !vcomp_linv.
        rewrite !id2_rwhisker.
        rewrite id2_left, id2_right.
        apply idpath.
      - rewrite <- !rwhisker_vcomp.
        unfold inv.
        rewrite !iso_inserter_ump_cell_pr1.
        rewrite id2_rwhisker.
        apply vcomp_linv.
    Qed.

    Definition is_invertible_2cell_iso_inserter_ump_cell
      : is_invertible_2cell (iso_inserter_ump_cell H α p).
    Proof.
      use make_is_invertible_2cell.
      - exact inv.
      - exact is_invertible_2cell_iso_inserter_ump_cell_inv_right.
      - exact is_invertible_2cell_iso_inserter_ump_cell_inv_left.
    Defined.
  End Invertible2CellIso_inserterUMP.

  Definition isaprop_has_iso_inserter_ump
             (HB_2_1 : is_univalent_2_1 B)
             (cone : iso_inserter_cone)
    : isaprop (has_iso_inserter_ump cone).
  Proof.
    use invproofirrelevance.
    intros χ₁ χ₂.
    use pathsdirprod.
    - use funextsec.
      intro q.
      use path_iso_inserter_1cell.
      + apply (isotoid_2_1 HB_2_1).
        use make_invertible_2cell.
        * use (iso_inserter_ump_cell χ₁).
          ** exact (iso_inserter_1cell_pr1 (pr1 χ₁ q) • (iso_inserter_1cell_pr1 (pr1 χ₂ q))^-1).
          ** rewrite <- !rwhisker_vcomp.
             rewrite !vassocl.
             etrans.
             {
               apply maponpaths.
               rewrite !vassocr.
               apply maponpaths_2.
               exact (iso_inserter_1cell_cell (pr1 χ₁ q)).
             }
             rewrite !vassocr.
             rewrite rassociator_lassociator.
             rewrite id2_left.
             rewrite !vassocl.
             apply maponpaths.
             use vcomp_move_R_Mp ; [ is_iso | ].
             cbn.
             rewrite !vassocl.
             refine (!_).
             etrans.
             {
               do 2 apply maponpaths.
               rewrite !vassocr.
               exact (iso_inserter_1cell_cell (pr1 χ₂ q)).
             }
             etrans.
             {
               apply maponpaths.
               rewrite !vassocr.
               rewrite rassociator_lassociator.
               rewrite id2_left.
               apply idpath.
             }
             rewrite !vassocr.
             rewrite rwhisker_vcomp.
             rewrite vcomp_linv.
             rewrite id2_rwhisker.
             apply id2_left.
        * use is_invertible_2cell_iso_inserter_ump_cell.
          is_iso.
          apply property_from_invertible_2cell.
      + rewrite idtoiso_2_1_isotoid_2_1.
        cbn.
        rewrite iso_inserter_ump_cell_pr1.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
    - use pathsdirprod.
      + use funextsec ; intro x.
        use funextsec ; intro u₁.
        use funextsec ; intro u₂.
        use funextsec ; intro φ.
        use funextsec ; intro p.
        use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        use (iso_inserter_ump_eq χ₁).
        * exact φ.
        * exact p.
        * exact (pr2 ((pr12 χ₁) x u₁ u₂ φ p)).
        * exact (pr2 ((pr12 χ₂) x u₁ u₂ φ p)).
      + do 9 (use funextsec ; intro).
        apply cellset_property.
  Qed.

  (**
   3. The universal property gives an equivalence of categories
   *)
  Definition iso_inserter_cone_functor_data
             (cone : iso_inserter_cone)
             (x : B)
    : functor_data
        (hom x cone)
        (cat_iso_inserter (post_comp x f) (post_comp x g)).
  Proof.
    use make_functor_data.
    - refine (λ h, h · iso_inserter_cone_pr1 cone
                   ,,
                   _).
      use inv2cell_to_z_iso.
      use make_invertible_2cell.
      + exact (rassociator _ _ _ • (h ◃ iso_inserter_cone_cell cone) • lassociator _ _ _).
      + is_iso.
        apply property_from_invertible_2cell.
    - refine (λ x y g, g ▹ _ ,, _) ; cbn.
      abstract
        (rewrite !vassocr ;
         rewrite rwhisker_rwhisker_alt ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite !vassocr ;
         rewrite vcomp_whisker ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite rwhisker_rwhisker ;
         apply idpath).
  Defined.

  Definition iso_inserter_cone_functor_is_functor
             (cone : iso_inserter_cone)
             (x : B)
    : is_functor (iso_inserter_cone_functor_data cone x).
  Proof.
    split.
    - intro h.
      use eq_cat_iso_inserter ; cbn.
      rewrite id2_rwhisker.
      apply idpath.
    - intros z₁ z₂ z₃ h₁ h₂.
      use eq_cat_iso_inserter ; cbn.
      rewrite rwhisker_vcomp.
      apply idpath.
  Qed.

  Definition iso_inserter_cone_functor
             (cone : iso_inserter_cone)
             (x : B)
    : hom x cone ⟶ cat_iso_inserter (post_comp x f) (post_comp x g).
  Proof.
    use make_functor.
    - exact (iso_inserter_cone_functor_data cone x).
    - exact (iso_inserter_cone_functor_is_functor cone x).
  Defined.

  Definition is_universal_iso_inserter_cone
             (cone : iso_inserter_cone)
    : UU
    := ∏ (x : B),
       adj_equivalence_of_cats (iso_inserter_cone_functor cone x).

  Section MakeUniversalIso_inserterCone.
    Context (HB_2_1 : is_univalent_2_1 B)
            (cone : iso_inserter_cone)
            (H : has_iso_inserter_ump cone)
            (x : B).

    Definition make_is_universal_iso_inserter_cone_full
      : full (iso_inserter_cone_functor cone x).
    Proof.
      intros u₁ u₂ α.
      pose (p := pr2 α).
      cbn in p.
      rewrite !vassocr in p.
      apply hinhpr.
      simple refine (_ ,, _).
      - use (iso_inserter_ump_cell H).
        + exact (pr1 α).
        + exact p.
      - use eq_cat_iso_inserter ; cbn in *.
        apply iso_inserter_ump_cell_pr1.
    Defined.

    Definition make_is_universal_iso_inserter_cone_faithful
      : faithful (iso_inserter_cone_functor cone x).
    Proof.
      intros u₁ u₂ α.
      use invproofirrelevance.
      intros φ₁ φ₂.
      use subtypePath.
      {
        intro.
        apply homset_property.
      }
      use (iso_inserter_ump_eq_alt H).
      - pose (pr2 α) as p.
        cbn in p.
        rewrite !vassocr in p.
        refine (_ @ p @ _).
        + do 2 apply maponpaths.
          exact (maponpaths pr1 (pr2 φ₁)).
        + do 3 apply maponpaths_2.
          apply maponpaths.
          exact (!(maponpaths pr1 (pr2 φ₁))).
      - exact (maponpaths pr1 (pr2 φ₁) @ !(maponpaths pr1 (pr2 φ₂))).
    Qed.

    Definition make_is_universal_iso_inserter_cone_essentially_surjective
      : essentially_surjective (iso_inserter_cone_functor cone x).
    Proof.
      intros h.
      use hinhpr.
      simple refine (_ ,, _).
      - exact (iso_inserter_ump_mor H (pr1 h) (pr2 h)).
      - use z_iso_cat_iso_inserter.
        + simple refine (_ ,, _) ; cbn.
          * apply iso_inserter_ump_mor_pr1.
          * abstract
              (cbn ;
               rewrite !vassocl ;
               use vcomp_move_R_pM ; [ is_iso | ] ;
               cbn ;
               rewrite !vassocr ;
               apply iso_inserter_ump_mor_cell).
        + use is_inv2cell_to_is_z_iso.
          apply property_from_invertible_2cell.
    Defined.
  End MakeUniversalIso_inserterCone.

  Definition make_is_universal_iso_inserter_cone
             (HB_2_1 : is_univalent_2_1 B)
             (cone : iso_inserter_cone)
             (H : has_iso_inserter_ump cone)
    : is_universal_iso_inserter_cone cone.
  Proof.
    intro x.
    use rad_equivalence_of_cats.
    - apply is_univ_hom.
      exact HB_2_1.
    - use full_and_faithful_implies_fully_faithful.
      split.
      + apply make_is_universal_iso_inserter_cone_full.
        apply H.
      + apply make_is_universal_iso_inserter_cone_faithful.
        apply H.
    - apply make_is_universal_iso_inserter_cone_essentially_surjective.
      apply H.
  Defined.

  Definition isaprop_is_universal_iso_inserter_cone
             (HB_2_1 : is_univalent_2_1 B)
             (cone : iso_inserter_cone)
    : isaprop (is_universal_iso_inserter_cone cone).
  Proof.
    use impred ; intro x.
    use isofhlevelweqf.
    - exact (@left_adjoint_equivalence
               bicat_of_univ_cats
               (univ_hom HB_2_1 x cone)
               (@univalent_cat_iso_inserter
                  (univ_hom HB_2_1 _ _)
                  (univ_hom HB_2_1 _ _)
                  (post_comp x f)
                  (post_comp x g))
               (iso_inserter_cone_functor cone x)).
    - exact (@adj_equiv_is_equiv_cat
               (univ_hom HB_2_1 x cone)
               (@univalent_cat_iso_inserter
                  (univ_hom HB_2_1 _ _)
                  (univ_hom HB_2_1 _ _)
                  (post_comp x f)
                  (post_comp x g))
               (iso_inserter_cone_functor cone x)).
    - apply isaprop_left_adjoint_equivalence.
      exact univalent_cat_is_univalent_2_1.
  Defined.

  Section UniversalConeHasUMP.
    Context {cone : iso_inserter_cone}
            (H : is_universal_iso_inserter_cone cone).

    Section UMP1.
      Context (q : iso_inserter_cone).

      Let alg : cat_iso_inserter (post_comp q f) (post_comp q g)
        := iso_inserter_cone_pr1 q ,, iso_inserter_cone_cell q.

      Definition universal_iso_inserter_cone_has_ump_1_mor
        : q --> cone
        := right_adjoint (H q) alg.

      Definition universal_iso_inserter_cone_has_ump_1_pr1
        : invertible_2cell
            (universal_iso_inserter_cone_has_ump_1_mor · iso_inserter_cone_pr1 cone)
            (iso_inserter_cone_pr1 q).
      Proof.
        use z_iso_to_inv2cell.
        exact (from_z_iso_cat_iso_inserter
                 (nat_z_iso_pointwise_z_iso
                    (counit_nat_z_iso_from_adj_equivalence_of_cats (H q))
                    alg)).
      Defined.

      Definition universal_iso_inserter_cone_has_ump_1_cell
        : (_ ◃ iso_inserter_cone_cell cone)
          • lassociator _ _ _
          • (universal_iso_inserter_cone_has_ump_1_pr1 ▹ g)
          =
          lassociator _ _ _
          • (universal_iso_inserter_cone_has_ump_1_pr1 ▹ f)
          • iso_inserter_cone_cell q.
      Proof.
        cbn.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          exact (!(pr2 (counit_from_left_adjoint (pr1 (H q)) alg))).
        }
        cbn.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      Qed.
    End UMP1.

    Definition universal_iso_inserter_cone_has_ump_1
      : has_iso_inserter_ump_1 cone.
    Proof.
      intro q.
      use make_iso_inserter_1cell.
      - exact (universal_iso_inserter_cone_has_ump_1_mor q).
      - exact (universal_iso_inserter_cone_has_ump_1_pr1 q).
      - exact (universal_iso_inserter_cone_has_ump_1_cell q).
    Defined.

    Section UMP2.
      Context {x : B}
              {u₁ u₂ : x --> cone}
              (α : u₁ · iso_inserter_cone_pr1 cone
                   ==>
                   u₂ · iso_inserter_cone_pr1 cone)
              (p : rassociator _ _ _
                   • (u₁ ◃ iso_inserter_cone_cell cone)
                   • lassociator _ _ _
                   • (α ▹ g)
                   =
                   (α ▹ f)
                   • rassociator _ _ _
                   • (u₂ ◃ iso_inserter_cone_cell cone)
                   • lassociator _ _ _).

      Definition universal_iso_inserter_cone_has_ump_2_cell
        : u₁ ==> u₂.
      Proof.
        apply (invmap (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))).
        simple refine (_ ,, _).
        - exact α.
        - abstract
            (cbn ;
             rewrite !vassocr ;
             exact p).
      Defined.

      Definition universal_iso_inserter_cone_has_ump_2_pr1
        : universal_iso_inserter_cone_has_ump_2_cell ▹ iso_inserter_cone_pr1 cone
          =
          α.
      Proof.
        exact (maponpaths
                 pr1
                 (homotweqinvweq
                    (make_weq _ (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))
                    _)).
      Qed.
    End UMP2.

    Definition universal_iso_inserter_cone_has_ump_2
      : has_iso_inserter_ump_2 cone.
    Proof.
      intros x u₁ u₂ α p.
      simple refine (_ ,, _).
      - exact (universal_iso_inserter_cone_has_ump_2_cell α p).
      - exact (universal_iso_inserter_cone_has_ump_2_pr1 α p).
    Defined.

    Definition universal_iso_inserter_cone_has_ump_eq
      : has_iso_inserter_ump_eq cone.
    Proof.
      intros x u₁ u₂ α p φ₁ φ₂ q₁ q₂.
      use (invmaponpathsweq
             (make_weq
                _
                (fully_faithful_from_equivalence _ _ _ (H x) u₁ u₂))) ; cbn.
      use subtypePath.
      {
        intro.
        apply cellset_property.
      }
      cbn.
      exact (q₁ @ !q₂).
    Qed.

    Definition universal_iso_inserter_cone_has_ump
      : has_iso_inserter_ump cone.
    Proof.
      simple refine (_ ,, _ ,, _).
      - exact universal_iso_inserter_cone_has_ump_1.
      - exact universal_iso_inserter_cone_has_ump_2.
      - exact universal_iso_inserter_cone_has_ump_eq.
    Defined.
  End UniversalConeHasUMP.

  Definition iso_inserter_ump_weq_universal
             (HB_2_1 : is_univalent_2_1 B)
             (cone : iso_inserter_cone)
    : has_iso_inserter_ump cone ≃ is_universal_iso_inserter_cone cone.
  Proof.
    use weqimplimpl.
    - exact (make_is_universal_iso_inserter_cone HB_2_1 cone).
    - exact universal_iso_inserter_cone_has_ump.
    - exact (isaprop_has_iso_inserter_ump HB_2_1 cone).
    - exact (isaprop_is_universal_iso_inserter_cone HB_2_1 cone).
  Defined.
End IsoInserters.

Arguments iso_inserter_cone {_ _ _} _ _.

(**
 4. Bicategories with iso_inserters
 *)
Definition has_iso_inserters
           (B : bicat)
  : UU
  := ∏ (b₁ b₂ : B)
       (f g : b₁ --> b₂),
     ∑ (i : B)
       (m : i --> b₁)
       (α : invertible_2cell (m · f) (m · g)),
     has_iso_inserter_ump (make_iso_inserter_cone i m α).

(**
 5. Iso_inserters are faithful
 *)
Definition iso_inserter_faithful
           {B : bicat}
           {b₁ b₂ : B}
           {f g : b₁ --> b₂}
           {i : B}
           (m : i --> b₁)
           (α : invertible_2cell (m · f) (m · g))
           (H : has_iso_inserter_ump (make_iso_inserter_cone i m α))
  : faithful_1cell m.
Proof.
  intros x g₁ g₂ β₁ β₂ p.
  use (iso_inserter_ump_eq_alt H) ; cbn.
  - abstract
      (rewrite rwhisker_rwhisker_alt ;
       rewrite !vassocl ;
       apply maponpaths ;
       rewrite rwhisker_rwhisker ;
       rewrite !vassocr ;
       apply maponpaths_2 ;
       refine (!_) ;
       apply vcomp_whisker).
  - exact p.
Defined.

(**
 6. Iso_inserters are conservative
 *)
Section Iso_inserterConservative.
  Context {B : bicat}
          {b₁ b₂ : B}
          {f g : b₁ --> b₂}
          {i : B}
          (m : i --> b₁)
          (α : invertible_2cell (m · f) (m · g))
          (H : has_iso_inserter_ump (make_iso_inserter_cone i m α))
          {x : B}
          {g₁ g₂ : x --> i}
          (β : g₁ ==> g₂)
          (Hβ : is_invertible_2cell (β ▹ m)).

  Definition iso_inserter_conservative_inv
    : g₂ ==> g₁.
  Proof.
    use (iso_inserter_ump_cell H).
    - exact (Hβ^-1).
    - abstract
        (cbn ;
         use vcomp_move_R_Mp ; [ is_iso | ] ; cbn ;
         rewrite !vassocl ;
         rewrite rwhisker_rwhisker ;
         use vcomp_move_L_pM ; [ is_iso | ] ; cbn ;
         rewrite !vassocr ;
         apply maponpaths_2 ;
         rewrite rwhisker_rwhisker_alt ;
         rewrite !vassocl ;
         apply maponpaths ;
         rewrite vcomp_whisker ;
         apply idpath).
  Defined.

  Definition iso_inserter_conservative_rinv
    : β • iso_inserter_conservative_inv = id₂ _.
  Proof.
    use (iso_inserter_ump_eq_alt H) ; cbn.
    - rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply maponpaths.
      rewrite rwhisker_rwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite vcomp_whisker.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      unfold iso_inserter_conservative_inv.
      rewrite (iso_inserter_ump_cell_pr1 H).
      rewrite id2_rwhisker.
      apply vcomp_rinv.
  Qed.

  Definition iso_inserter_conservative_linv
    : iso_inserter_conservative_inv • β = id₂ _.
  Proof.
    use (iso_inserter_ump_eq_alt H) ; cbn.
    - rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply maponpaths.
      rewrite rwhisker_rwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite vcomp_whisker.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      unfold iso_inserter_conservative_inv.
      rewrite (iso_inserter_ump_cell_pr1 H).
      rewrite id2_rwhisker.
      apply vcomp_linv.
  Qed.
End Iso_inserterConservative.

Definition iso_inserter_conservative
           {B : bicat}
           {b₁ b₂ : B}
           {f g : b₁ --> b₂}
           {i : B}
           (m : i --> b₁)
           (α : invertible_2cell (m · f) (m · g))
           (H : has_iso_inserter_ump (make_iso_inserter_cone i m α))
  : conservative_1cell m.
Proof.
  intros x g₁ g₂ β Hβ.
  use make_is_invertible_2cell.
  - exact (iso_inserter_conservative_inv m α H β Hβ).
  - exact (iso_inserter_conservative_rinv m α H β Hβ).
  - exact (iso_inserter_conservative_linv m α H β Hβ).
Defined.

Definition iso_inserter_discrete
           {B : bicat}
           {b₁ b₂ : B}
           {f g : b₁ --> b₂}
           {i : B}
           (m : i --> b₁)
           (α : invertible_2cell (m · f) (m · g))
           (H : has_iso_inserter_ump (make_iso_inserter_cone i m α))
  : discrete_1cell m.
Proof.
  split.
  - exact (iso_inserter_faithful m α H).
  - exact (iso_inserter_conservative m α H).
Defined.


Require Import UniMath.Algebra.RigsAndRings.
Require Import UniMath.MoreFoundations.Subtypes.
Require Import UniMath.Topology.Topology.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Export UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.categories.preorder_categories.
Require Import UniMath.CategoryTheory.categories.commrings.
Require Import UniMath.AlgebraicGeometry.Topology.

Local Open Scope cat.
Local Open Scope logic.
Local Open Scope subtype.
Local Open Scope open.

(* The category of open subsets of a topological space. *)

Section open_category.
  Context (X : TopologicalSpace).

  Definition open_po : po (@Open X) :=
    make_po _ (isporesrel _ _ (subtype_containment_ispreorder X)).

  Definition open_category : category := po_category open_po.
End open_category.

Section sheaf_commring_prop.
  Context {X : TopologicalSpace}
          (F' : functor_data (open_category X)^op commring_precategory).

  Definition F (U : Open) : commring := F' U.

  Definition restriction {U V : Open} (H : U ⊆ V) : ringfun (F V) (F U) := #F' H.

  Definition restrict (A : hsubtype Open) (f : F (⋃ A)) (U : A) : F (pr1 U) :=
    restriction (contained_in_union_open U) f.

  Definition agree_on_intersections {A : hsubtype Open}
                                    (g : ∏ U : A, F (pr1 U)) : UU :=
    ∏ U V : A, restriction (intersection_contained1 _ _) (g U) =
               restriction (intersection_contained2 _ _) (g V).

  Definition locality : hProp := ∀ (A : hsubtype Open) (f g : F (⋃ A)),
      restrict A f ~ restrict A g ⇒ f = g.

  Definition gluing : hProp := ∀ (A : hsubtype Open) (g : ∏ U : A, F (pr1 U)),
      agree_on_intersections g ⇒ ∃ f, restrict A f ~ g.
End sheaf_commring_prop.

Section sheaf_commring.
  Context {X : TopologicalSpace}.

  Definition sheaf_commring : UU :=
    ∑ F : (open_category X)^op ⟶ commring_precategory, locality F ∧ gluing F.

  Definition make_sheaf_commring F l g : sheaf_commring := F ,, l ,, g.

  Definition sheaf_commring_functor (F : sheaf_commring) :
    (open_category X)^op ⟶ commring_precategory := pr1 F.
  Coercion sheaf_commring_functor : sheaf_commring >-> functor.

  Definition sheaf_commring_locality (F : sheaf_commring) : locality F := pr12 F.

  Definition sheaf_commring_gluing (F : sheaf_commring) : gluing F := pr22 F.
End sheaf_commring.

Arguments sheaf_commring _ : clear implicits.


(**

Syntax of the calculus of constructions as in Streicher
"Semantics of Type Theory" formalized as a 2-sorted
binding signature.

Written by: Anders Mörtberg, 2021 (adapted from CCS.v)

version for simplified notion of HSS by Ralph Matthes (2022, 2023)
the file is identical to the homonymous file in the parent directory, except for importing files from the present directory

*)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.MoreFoundations.Tactics.

Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Combinatorics.Lists.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.limits.graphs.colimits.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.products.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.exponentials.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Chains.All.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Colimits.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Groupoids.

Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SumOfSignatures.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.SubstitutionSystems.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.LiftingInitial_alt.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MonadsFromSubstitutionSystems.
Require Import UniMath.SubstitutionSystems.SignatureExamples.
Require Import UniMath.SubstitutionSystems.MultiSorted_alt.
Require Import UniMath.SubstitutionSystems.SimplifiedHSS.MultiSortedMonadConstruction_alt.
Require Import UniMath.SubstitutionSystems.MonadsMultiSorted_alt.

Local Open Scope cat.

Section ccs.

(* Was there a general version of this somewhere? *)
Definition six_rec {A : UU} (a b c d e f : A) : stn 6 → A.
Proof.
induction 1 as [n p].
induction n as [|n _]; [apply a|].
induction n as [|n _]; [apply b|].
induction n as [|n _]; [apply c|].
induction n as [|n _]; [apply d|].
induction n as [|n _]; [apply e|].
induction n as [|n _]; [apply f|].
induction (nopathsfalsetotrue p).
Defined.

(** We assume a two element set of sorts *)
Definition sort : hSet := (bool,,isasetbool).

Local Lemma hsort : isofhlevel 3 sort.
Proof.
exact (isofhlevelssnset 1 sort (setproperty sort)).
Defined.

Definition ty : sort := true.
Definition el : sort := false.

Let sortToSet : category := [path_pregroupoid sort hsort,HSET].
Let sortToSet2 := [sortToSet,sortToSet].

Local Lemma BinCoprodSortToSet : BinCoproducts sortToSet.
Proof.
apply BinCoproducts_functor_precat, BinCoproductsHSET.
Defined.

Local Lemma TerminalSortToSet : Terminal sortToSet.
Proof.
apply Terminal_functor_precat, TerminalHSET.
Defined.

Local Lemma BinProd : BinProducts [sortToSet,HSET].
Proof.
apply BinProducts_functor_precat, BinProductsHSET.
Defined.

(** Some notations *)
Local Infix "::" := (@cons _).
Local Notation "[]" := (@nil _) (at level 0, format "[]").
Local Notation "a + b" := (setcoprod a b) : set.
Local Notation "'Id'" := (functor_identity _).
Local Notation "a ⊕ b" := (BinCoproductObject (BinCoprodSortToSet a b)).
Local Notation "'1'" := (TerminalObject TerminalSortToSet).
Local Notation "F ⊗ G" := (BinProduct_of_functors BinProd F G).

(** The grammar of expressions and objects from page 157:
<<
E ::= (Πx:E) E                product of types
    | Prop                    type of propositions
    | Proof(t)                type of proofs of proposition t

t ::= x                       variable
    | (λx:E) t                function abstraction
    | App([x:E] E, t, t)      function application
    | (∀x:E) t                universal quantification
>>

We refer to the first syntactic class as ty and the second as el.
We first reformulate the rules as follows:
<<
A,B ::= Π(A,x.B)              product of types
      | Prop                  type of propositions
      | Proof(t)              type of proofs of proposition t

t,u ::= x                     variable
      | λ(A,x.t)              function abstraction
      | App(A,x.B,t,u)        function application
      | ∀(A,x.t)              universal quantification
>>

This grammar then gives 6 operations, to the left as Vladimir's restricted
2-sorted signature (where el is 0 and ty is 1) and to the right as a
 multisorted signature:

((0, 1), (1, 1), 1)                 = (([],ty), ([el], ty), ty)
(1)                                 = ([],ty)
((0, 0), 1)                         = (([], el), ty)
((0, 1), (1, 0), 0)                 = (([], ty), ([el], el), el)
((0, 1), (1, 1), (0, 0), (0, 0), 0) = (([], ty), ([el], ty), ([], el), ([], el), el)
((0, 1), (1, 0), 0)                 = (([], ty), ([el], el), el)

*)

(** The multisorted signature of CC-S *)
Definition CCS_Sig : MultiSortedSig sort.
Proof.
use make_MultiSortedSig.
- exact (stn 6,,isasetstn 6).
- apply six_rec.
  + exact ((([],,ty) :: (cons el [],,ty) :: nil),,ty).
  + exact ([],,ty).
  + exact ((([],,el) :: nil),,ty).
  + exact ((([],,ty) :: (cons el [],,el) :: nil),,el).
  + exact ((([],,ty) :: (cons el [],,ty) :: ([],,el) :: ([],,el) :: nil),,el).
  + exact ((([],,ty) :: (cons el [],,el) :: nil),,el).
Defined.

Definition CCS_Signature : Signature sortToSet _ _ :=
  MultiSortedSigToSignatureSet sort hsort CCS_Sig.

Definition CCS_Functor : functor sortToSet2 sortToSet2 :=
  Id_H _ BinCoprodSortToSet CCS_Signature.

Lemma CCS_Functor_Initial : Initial (FunctorAlg CCS_Functor).
Proof.
apply SignatureInitialAlgebra.
- apply InitialHSET.
- apply ColimsHSET_of_shape.
- apply is_omega_cocont_MultiSortedSigToSignature.
  + apply ProductsHSET.
  + apply Exponentials_functor_HSET.
  + apply ColimsHSET_of_shape.
Defined.

Definition CCS_Monad : Monad sortToSet :=
  MultiSortedSigToMonadSet sort hsort CCS_Sig.

(** Extract the constructors from the initial algebra *)
Definition CCS_M : sortToSet2 :=
  alg_carrier _ (InitialObject CCS_Functor_Initial).

Let CCS_M_mor : sortToSet2⟦CCS_Functor CCS_M,CCS_M⟧ :=
  alg_map _ (InitialObject CCS_Functor_Initial).

Let CCS_M_alg : algebra_ob CCS_Functor :=
  InitialObject CCS_Functor_Initial.

(** The variables *)
Definition var_map : sortToSet2⟦Id,CCS_M⟧ :=
  BinCoproductIn1 (BinCoproducts_functor_precat _ _ _ _ _) · CCS_M_mor.

Definition Pi_source : functor sortToSet2 sortToSet2 :=
  ( post_comp_functor (projSortToSet sort hsort ty) ⊗ ( pre_comp_functor (sorted_option_functorSet sort hsort el)
                                                 ∙ post_comp_functor (projSortToC sort hsort _ ty)))
  ∙ (post_comp_functor (hat_functorSet sort hsort ty)).

(** The Pi constructor *)
Definition Pi_map : sortToSet2⟦Pi_source CCS_M,CCS_M⟧ :=
    (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 0)%stn)
  · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
  · CCS_M_mor.

Definition Prop_source : functor sortToSet2 sortToSet2.
Proof.
set (T := constant_functor [sortToSet,sortToSet] [sortToSet,HSET]
                           (constant_functor sortToSet HSET (TerminalObject TerminalHSET))).
exact (T ∙ post_comp_functor (hat_functorSet sort hsort ty)).
Defined.

Definition Prop_map : sortToSet2⟦Prop_source CCS_M,CCS_M⟧ :=
    (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 1%nat)%stn)
  · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
  · CCS_M_mor.

Definition Proof_source : functor sortToSet2 sortToSet2 :=
  post_comp_functor (projSortToSet sort hsort el) ∙ post_comp_functor (hat_functorSet sort hsort ty).

(** The Proof constructor *)
Definition Proof_map : sortToSet2⟦Proof_source CCS_M,CCS_M⟧ :=
    (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 2)%stn)
  · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
  · CCS_M_mor.

Definition lam_source : functor sortToSet2 sortToSet2 :=
  (post_comp_functor (projSortToSet sort hsort ty) ⊗ (pre_comp_functor (sorted_option_functorSet sort hsort el)
   ∙ post_comp_functor (projSortToC sort hsort _ el)))
  ∙ (post_comp_functor (hat_functorSet sort hsort el)).

(** The lambda constructor *)
Definition lam_map : sortToSet2⟦lam_source CCS_M,CCS_M⟧ :=
    (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 3)%stn)
  · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
  · CCS_M_mor.

Definition app_source : functor sortToSet2 sortToSet2 :=
  ((post_comp_functor (projSortToSet sort hsort ty)) ⊗
  ((pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToSet sort hsort ty)) ⊗
  ((post_comp_functor (projSortToSet sort hsort el)) ⊗
   (post_comp_functor (projSortToSet sort hsort el)))))
 ∙ (post_comp_functor (hat_functorSet sort hsort el)).

(** The app constructor *)
Definition app_map : sortToSet2⟦app_source CCS_M,CCS_M⟧ :=
  (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 4)%stn)
    · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
    · CCS_M_mor.

Definition forall_source : functor sortToSet2 sortToSet2 :=
  ((post_comp_functor (projSortToSet sort hsort ty)) ⊗
   (pre_comp_functor (sorted_option_functorSet sort hsort el) ∙ post_comp_functor (projSortToSet sort hsort el)))
  ∙ post_comp_functor (hat_functorSet sort hsort el).

(** The ∀ constructor *)
Definition forall_map : sortToSet2⟦forall_source CCS_M,CCS_M⟧ :=
    (CoproductIn _ _ (Coproducts_functor_precat _ _ _ _ _) (● 5)%stn)
  · (BinCoproductIn2 (BinCoproducts_functor_precat _ _ _ _ _))
  · CCS_M_mor.

Definition make_CCS_Algebra X
  (fvar    : sortToSet2⟦Id,X⟧)
  (fPi     : sortToSet2⟦Pi_source X,X⟧)
  (fProp   : sortToSet2⟦Prop_source X,X⟧)
  (fProof  : sortToSet2⟦Proof_source X,X⟧)
  (flam    : sortToSet2⟦lam_source X,X⟧)
  (fapp    : sortToSet2⟦app_source X,X⟧)
  (fforall : sortToSet2⟦forall_source X,X⟧) : algebra_ob CCS_Functor.
Proof.
apply (tpair _ X).
use (BinCoproductArrow _ fvar).
use CoproductArrow.
intros i.
induction i as [n p].
repeat (induction n as [|n _]; try induction (nopathsfalsetotrue p)).
- exact fPi.
- exact fProp.
- exact fProof.
- exact flam.
- simpl in fapp.
  exact fapp.
- exact fforall.
Defined.

(** The recursor for ccs *)
Definition foldr_map X
  (fvar    : sortToSet2⟦Id,X⟧)
  (fPi     : sortToSet2⟦Pi_source X,X⟧)
  (fProp   : sortToSet2⟦Prop_source X,X⟧)
  (fProof  : sortToSet2⟦Proof_source X,X⟧)
  (flam    : sortToSet2⟦lam_source X,X⟧)
  (fapp    : sortToSet2⟦app_source X,X⟧)
  (fforall : sortToSet2⟦forall_source X,X⟧) :
  algebra_mor _ CCS_M_alg (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall).
Proof.
apply (InitialArrow CCS_Functor_Initial (make_CCS_Algebra X fvar fPi fProp fProof flam fapp fforall)).
Defined.

End ccs.


Require Export ZArith_base.

Parameter R : Set.

Delimit Scope XR_scope with R.
Bind Scope XR_scope with R.
Local Open Scope XR_scope.

Parameter R0 : R.
Parameter R1 : R.
Parameter Rplus : R -> R -> R.
Parameter Rmult : R -> R -> R.
Parameter Ropp : R -> R.
Parameter Rinv : R -> R.
Parameter Rlt : R -> R -> Prop.
Parameter up : R -> Z.

Infix "+" := Rplus : XR_scope.
Infix "*" := Rmult : XR_scope.
Notation "- x" := (Ropp x) : XR_scope.
Notation "/ x" := (Rinv x) : XR_scope.

Infix "<" := Rlt : XR_scope.

Definition Rle (r1 r2:R) : Prop := r1 < r2 \/ r1 = r2.
Definition Rminus (r1 r2:R) : R := r1 + - r2.
Definition Rdiv (r1 r2:R) : R := r1 * / r2.

Infix "-" := Rminus : XR_scope.
Infix "/" := Rdiv   : XR_scope.

Infix "<=" := Rle : XR_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z) : XR_scope.
Notation "x <= y < z"  := (x <= y /\ y <  z) : XR_scope.
Notation "x < y < z"   := (x <  y /\ y <  z) : XR_scope.
Notation "x < y <= z"  := (x <  y /\ y <= z) : XR_scope.


Context {var : Type} (var_to_game : var -> strict.game).
Fixpoint syntax_to_game (s : @affine.syntax var) : strict.game :=
match s with
 | affine.Var v => var_to_game v
 | affine.Zero => strict.bottom
 | affine.One => strict.top
 | affine.Tensor Left Right => syntax_to_game Left ⊗ syntax_to_game Right
end.

Definition sequent_to_game (context : seq (@affine.syntax var))
  (result : @affine.syntax var) : strict.game :=
  foldl (fun g1 g2 => (g1) ~* (g2))
        (syntax_to_game result)
        (map (fun g => ~syntax_to_game g) context).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e511m187_22limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_5limbs_donna.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e511m481_11limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition square :
  { square : feBW_loose -> feBW_tight
  | forall a, phiBW_tight (square a) = F.mul (phiBW_loose a) (phiBW_loose a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_square ().
  Show Ltac Profile.
Time Defined.

Print Assumptions square.


Require Import Coq.Lists.List
               Coq.Sets.Ensembles.

Section R.
Variable  r  : forall a : Type, list a -> list a .
Variable a_star : forall a b, list a -> list b .

Theorem nil_thm : forall a, (r a) nil = nil.
Proof.
  intros. Admitted.
(* "if fixpoints are allowed then theorems hold only when a b are strict" *)

Theorem section1_thm : forall (x y : Type) (l : list x),
  a_star x y (r x l) = r y (a_star x y l).
Proof.
  intros. induction l.
  Admitted.
End R.

(* trying to replicate the definition of types as relations described in
   Theorems for Free! Going to define a relation between types and set
   + look into coq sets
   + describe relation between type and set
   + define the operations / relations between types product etc
*)
Section Types_as_Relations.
  Definition rset A := A -> Prop.
  Definition sub_rset {A} (s s': @rset A) := forall x : A, (s x -> s' x).
  Definition relation A B := @rset (A * B).

  Notation "M ':' A '<==>' B" :=
    (exists r : relation A B, sub_rset M r)(at level 60).

  Definition elm_rset {A} (x : A) (s : @rset A) := s x.
  Notation "x '\in' A" := (elm_rset x A)(at level 60).

  Definition ident_rel {A} := forall x : A, (x, x).


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e512m569_8limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (mul a b) = F.mul (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.