Set Implicit Arguments.

Require Import List Eqdep_dec.

Definition llist A n := {l : list A | length l = n}.

Lemma ll_proj_eq A n : forall (l l' : llist A n), proj1_sig l = proj1_sig l' -> l = l'.
 intros.
 destruct l.
 destruct l'.
 simpl in H.
 subst.
 f_equal.
 apply eq_proofs_unicity.
 decide equality.
Defined.

  Import Plus.

Program Definition llrev A n (l : llist A n) : llist A n :=
  rev l.
Obligation 1.
 destruct l.
 revert n e.
 induction x; intros.
  simpl in *; subst; reflexivity.
  simpl in *; subst.
  rewrite app_length.
  simpl.
  rewrite (IHx (length x)) by reflexivity.
  rewrite <- plus_Snm_nSm.
  rewrite plus_0_r.
  reflexivity.
Qed.

Program Definition llcons A n (x : A) (xs : llist A n) : llist A (S n) := cons x xs.
Obligation 1.
 destruct xs; subst.
 reflexivity.
Qed.

Program Definition llnil A : llist A 0 := nil.

Program Definition llhead A n (l : llist A (S n)) : A :=
  match l with
  | nil => _
  | cons x xs => x
  end.
Obligation 1.
 destruct l.
 simpl in *.
 subst; inversion e.
Qed.

Program Definition lltail A n (l : llist A (S n)) : llist A n :=
  match l with
  | nil => _
  | cons x xs => xs
  end.
Obligation 1.
 destruct l; simpl in *; subst.
 inversion e.
Qed.
Obligation 2.
  revert l x xs Heq_l.
  induction n; intuition;
   destruct l; simpl in *; subst;
   inversion e; reflexivity.
Qed.

Program Definition llsnoc A n (l : llist A n) a : llist A (S n) :=
  l ++ (a :: nil).
Obligation 1.
 rewrite app_length.
 rewrite plus_comm.
 destruct l.
 subst; reflexivity.
Qed.

Program Fixpoint llcohead A n (l : llist A (S n)) : A :=
  match l with
  | nil => _
  | cons x xs => match n with
     | O => x
     | S m => llcohead (n:=m) xs end
  end.
Obligation 1.
 destruct l; simpl in *; subst.
 inversion e.
Qed.
Obligation 2.
 destruct l; simpl in *; subst.
 inversion e; auto.
Qed.

Program Fixpoint llcotail A n (l : llist A (S n)) : llist A n :=
  match l with
  | nil => _
  | cons x xs => match n with
    | O => nil
    | S m => cons x (llcotail (n:=m) xs) end
  end.
Next Obligation.
 destruct l; simpl in *; subst.
 inversion e.
Qed.
Next Obligation.
 destruct l; simpl in *; subst.
 inversion e; auto.
Qed.

  Hint Resolve ll_proj_eq.
  Lemma llist_head_tail A n (l : llist A (S n)) : llcons (llhead l) (lltail l) = l.
   destruct l.
   destruct x.
    inversion e.
    auto with *.
  Defined.

  Hint Resolve llist_head_tail.

  Lemma llist_ind A : forall P : (forall n, llist A n -> Type),
    P O (llnil A) ->
    (forall n l, P n l -> forall a, P (S n) (llcons a l)) ->
    (forall n l, P n l).
   intros.
   induction n.
    destruct l.
    destruct x; subst.
     match goal with |- P 0 ?x => replace x with (llnil A); auto end.
     inversion e.

    replace l with (llcons (llhead l) (lltail l)); auto.
  Defined.

  Lemma llist_ind0 A : forall P : (llist A 0 -> Type),
    P (llnil A) -> (forall l, P l).
   intros.
   destruct l.
    destruct x; subst.
     match goal with |- P ?K => replace K with (llnil A); auto end.
     inversion e.
  Defined.

  Lemma llist_indS A : forall P : (forall n, llist A (S n) -> Type),
    (forall a,  P O (llcons a (llnil A))) ->
    (forall n l, P n l -> forall a, P (S n) (llcons a l)) ->
    (forall n l, P n l).
   intros.
   induction n.
    destruct l.
    destruct x; subst.
     inversion e.
     match goal with |- P 0 ?x => replace x with (llcons a (llnil A)); auto end.
     inversion e.
      destruct x.
       auto.
       inversion H0.

    replace l with (llcons (llhead l) (lltail l)); auto.
  Defined.

  Lemma llist_cotail A n a (l : llist A (S n)) :
      llcotail (llcons a l) = llcons a (llcotail l).
   revert a.
   revert n l.
   refine (llist_indS (fun l => _) _ _); intros.
    auto.
    rewrite H.
    apply ll_proj_eq.
    simpl.
    repeat f_equal.
    apply ll_proj_eq; auto.
  Qed.

  Lemma llist_cohead A n a (l : llist A (S n)) :
      llcohead (llcons a l) = llcohead l.
   destruct l.
   simpl.
   f_equal.
   apply ll_proj_eq.
   reflexivity.
  Qed.

  Lemma llist_snoc_cons A n a b (l : llist A n) :
     llsnoc (llcons a l) b = llcons a (llsnoc l b).
   revert a b.
   induction l using llist_ind; intros.
    auto.
    auto.
  Qed.

  Lemma llist_cohead_cotail A n (l : llist A (S n)) :
     llsnoc (llcotail l) (llcohead l) = l.
   revert n l;
   refine (llist_indS (fun l => _) _ _); intros.
    auto.
    rewrite llist_cotail.
    rewrite llist_snoc_cons.
    f_equal.
    auto.
    rewrite llist_cohead.
    trivial.
  Qed.

Lemma llist_snoc_ind A : forall P : (forall n, llist A n -> Type),
    P O (llnil A) ->
    (forall n l, P n l -> forall a, P (S n) (llsnoc l a)) ->
    (forall n l, P n l).
 intros.
 induction n.
  destruct l.
  destruct x; subst.
   match goal with |- P 0 ?x => replace x with (llnil A); auto end.
   inversion e.

  rewrite <- llist_cohead_cotail.
  firstorder.
Qed.

Ltac llniltac :=
 match goal with L : llist _ 0 |- _ => revert L; refine (llist_ind0 (fun L => _) _) end.

Lemma ll_snoc_rev_cons A n (l : llist A n) a : llcons a (llrev l) = llrev (llsnoc l a).
 revert a.
 induction l using llist_ind.
  auto.

  intros.

  apply ll_proj_eq.
  simpl.
  rewrite app_comm_cons.
  f_equal.
  generalize (IHl a0); intro.
  inversion H.
  firstorder.
Qed.

  Lemma llist_tail_cons A n a (l : llist A n) : lltail (llcons a l) = l.
   auto.
  Qed.

Lemma ll_cons_rev_snoc : forall A n (l : llist A n) a, llrev (llcons a l) = llsnoc (llrev l) a.
 auto.
Qed.

Lemma llist_ind1 A : forall P : (llist A 1 -> Type),
    (forall a, P (llcons a (llnil A))) -> (forall l, P l).
 intros.
 rewrite <- (llist_head_tail).
 generalize (lltail l); intro;
  llniltac.
 auto.
Defined.
Lemma llist_head_cons A n a (l : llist A n) : llhead (llcons a l) = a.
reflexivity.
Qed.

Lemma llist_cohead_snoc A n a (l : llist A n) : llcohead (llsnoc l a) = a.
induction l using llist_ind.
auto.
rewrite llist_snoc_cons.
rewrite <- IHl at 2.
rewrite llist_cohead.
auto.
Qed.

Lemma llhead_cohead A n (l : llist A (S n)) : llhead (llrev l) = llcohead l.
  rewrite <- (llist_cohead_cotail l).
  rewrite <- ll_snoc_rev_cons.
  rewrite llist_head_cons.
  rewrite llist_cohead_snoc.
  auto.
Qed.

Lemma llist_tail_snoc A n a (l : llist A (S n)) : lltail (llsnoc l a) = llsnoc (lltail l) a.
  revert n l; apply llist_indS; intros;
  auto.
Qed.

Hint Resolve llist_cotail.
Lemma ll_tail_rev_cotail A n (l : llist A (S n)) : lltail (llrev l) = llrev (llcotail l).
  revert n l; apply llist_indS; intros.
  auto.
  rewrite ll_cons_rev_snoc.
  rewrite llist_tail_snoc.
  rewrite H.
  rewrite <- ll_cons_rev_snoc.
  f_equal; auto.
Qed.
Hint Resolve ll_tail_rev_cotail.

Program Fixpoint llget A n (l : llist A n) m (H : n > m) : A :=
  match l with
  | nil => _
  | cons x xs => match m with O => x | S m' => @llget A (match n with O => _ | S n' => n' end) xs m' _ end
  end.
Next Obligation.
 destruct n.
  contradict H; firstorder.
  destruct l; destruct x; subst.
   inversion e.
   inversion Heq_l.
Qed.
Next Obligation.
 destruct l.
 simpl in *.
 destruct x0; inversion Heq_l; subst.
 auto.
Qed.
Next Obligation.
 destruct l; destruct x0; inversion Heq_l; subst.
 firstorder.
Qed.

 (*
Lemma twogt1 : 2 > 1.
firstorder.
Qed.

Compute (llget (llcons 1 (llcons 2 (llnil _))) twogt1).
*)


From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import FOL.Syntax.Facts FOL.Syntax.Theories.
From Undecidability Require Export FOL.Deduction.FullND.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Local Set Implicit Arguments.
Local Unset Strict Implicit.
Require Import Lia.

Set Default Proof Using "Type".

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

Section ND_def.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {ff : falsity_flag}.
  Context {p : peirce}.

  Theorem Weak A B phi :
    A ⊢ phi -> A <<= B -> B ⊢ phi.
  Proof.
    intros H. revert B.
    induction H; intros B HB; try unshelve (solve [econstructor; intuition]); try now econstructor.
  Qed.

  Hint Constructors prv : core.

  Theorem subst_Weak A phi xi :
    A ⊢ phi -> [phi[xi] | phi ∈ A] ⊢ phi[xi].
  Proof.
    induction 1 in xi |-*; comp.
    1-2,7-15: eauto using in_map.
    - apply AllI. setoid_rewrite map_map in IHprv. erewrite map_map, map_ext.
      apply IHprv. intros ?. cbn. now rewrite up_form.
    - specialize (IHprv xi). apply AllE with (t := t`[xi]) in IHprv. rewrite subst_comp in *.
      erewrite subst_ext; try apply IHprv. intros [|]; cbn; trivial.
      unfold funcomp. now setoid_rewrite subst_term_shift.
    - specialize (IHprv xi). eapply ExI with (t := t`[xi]). rewrite subst_comp in *.
      erewrite subst_ext; try apply IHprv. intros [|]; cbn; trivial.
      unfold funcomp. now setoid_rewrite subst_term_shift.
    - eapply ExE in IHprv1. eassumption. rewrite map_map.
      specialize (IHprv2 (up xi)). setoid_rewrite up_form in IHprv2.
      erewrite map_map, map_ext in IHprv2; try apply IHprv2. apply up_form.
  Qed.

  Definition cycle_shift n x :=
    if Dec (n = x) then $0 else $(S x).

  Lemma cycle_shift_shift n phi :
    bounded n phi -> phi[cycle_shift n] = phi[↑].
  Proof.
    intros H. apply (bounded_subst H). intros k. unfold cycle_shift. decide _; trivial; lia.
  Qed.

  Lemma cycle_shift_subject n phi :
    bounded (S n) phi -> phi[$n..][cycle_shift n] = phi.
  Proof.
    intros H. erewrite subst_comp, (bounded_subst H), subst_id; trivial.
    intros []; cbn; unfold cycle_shift; decide _; trivial; lia.
  Qed.

  Lemma nameless_equiv_all' A phi n :
    bounded_L n A -> bounded (S n) phi -> [p[↑] | p ∈ A] ⊢ phi <-> A ⊢ phi[$n..].
  Proof.
    intros H1 H2. split; intros H.
    - apply (subst_Weak ($n..)) in H. rewrite map_map in *.
      erewrite map_ext, map_id in H; try apply H. intros. apply subst_shift.
    - apply (subst_Weak (cycle_shift n)) in H. rewrite (map_ext_in _ (subst_form ↑)) in H.
      + now rewrite cycle_shift_subject in H.
      + intros psi HP. now apply cycle_shift_shift, H1.
  Qed.

  Lemma nameless_equiv_ex' A phi psi n :
    bounded_L n A -> bounded n phi -> bounded (S n) psi -> (psi::[p0[↑] | p0 ∈ A]) ⊢ phi[↑] <-> (psi[$n..]::A) ⊢ phi.
  Proof.
    intros HL Hphi Hpsi. split.
    - intros H % (subst_Weak ($n..)). cbn in *.
      rewrite map_map, (map_ext _ id), map_id in H.
      + now rewrite subst_shift in H.
      + intros. apply subst_shift.
    - intros H % (subst_Weak (cycle_shift n)). cbn in *.
      rewrite (map_ext_in _ (subst_form ↑)) in H.
      + now rewrite cycle_shift_subject, cycle_shift_shift in H.
      + intros theta HT. now apply cycle_shift_shift, HL.
  Qed.

  Lemma nameless_equiv_all A phi :
    { t : term | map (subst_form ↑) A ⊢ phi <-> A ⊢ phi[t..] }.
  Proof.
    destruct (find_bounded_L (phi::A)) as [n H].
    exists $n. apply nameless_equiv_all'.
    - intros ? ?. apply H. auto.
    - eapply bounded_up; try apply H; auto.
  Qed.

  Lemma nameless_equiv_ex A phi psi :
    { t : term | (phi :: map (subst_form ↑) A) ⊢ psi[↑] <-> (phi[t..]::A) ⊢ psi }.
  Proof.
    destruct (find_bounded_L (phi::psi::A)) as [n H].
    exists $n. apply nameless_equiv_ex'.
    - intros ? ?. apply H. auto.
    - apply H. auto.
    - eapply bounded_up; try apply H; auto.
  Qed.

  Lemma AllI_named (A : list form) (phi : form) :
    (forall t, A ⊢ phi[t..]) -> A ⊢ ∀phi.
  Proof.
    intros H. apply AllI.
    destruct (nameless_equiv_all A phi) as [t Ht].
    apply Ht, H.
  Qed.

  Lemma ExE_named A χ ψ :
    A ⊢ ∃ χ -> (forall t, (χ[t..]::A) ⊢ ψ) -> A ⊢ ψ.
  Proof.
    intros H1 H2. destruct (nameless_equiv_ex A χ ψ) as [t Ht].
    eapply ExE.
    - eassumption.
    - apply Ht, H2.
  Qed.

  Lemma imps T phi psi :
    T ⊢ phi → psi <-> (phi :: T) ⊢ psi.
  Proof.
    split; try apply II.
    intros H. apply IE with phi; auto. apply (Weak H). auto.
  Qed.

  Lemma CE T phi psi :
    T ⊢ phi ∧ psi -> T ⊢ phi /\ T ⊢ psi.
  Proof.
    intros H. split.
    - apply (CE1 H).
    - apply (CE2 H).
  Qed.

  Lemma DE' A phi :
    A ⊢ phi ∨ phi -> A ⊢ phi.
  Proof.
    intros H. apply (DE H); auto.
  Qed.

  Lemma switch_conj_imp alpha beta phi A :
    A ⊢ alpha ∧ beta → phi <-> A ⊢ alpha → beta → phi.
  Proof.
    split; intros H.
    - apply II, II. eapply IE.
      apply (@Weak A). apply H. firstorder.
      apply CI; apply Ctx; firstorder.
    - apply II. eapply IE. eapply IE.
      eapply Weak. apply H.
      firstorder.
      eapply CE1, Ctx; firstorder.
      eapply CE2, Ctx; firstorder.
  Qed.

  Lemma impl_prv A B phi :
    (rev B ++ A) ⊢ phi <-> A ⊢ (B ==> phi).
  Proof.
    revert A; induction B; intros A; cbn; simpl_list; intros.
    - firstorder.
    - split; intros.
      + eapply II. now eapply IHB.
      + now apply imps, IHB in H.
  Qed.

  Lemma subst_exist_prv {sigma N Gamma} phi :
    Gamma ⊢ phi[sigma] -> bounded N phi -> Gamma ⊢ exist_times N phi.
  Proof.
    induction N in phi, sigma |-*; intros; cbn.
    - erewrite <- (subst_bounded 0); eassumption.
    - rewrite iter_switch. eapply (IHN (S >> sigma)).
      cbn. eapply (ExI (sigma 0)).
      now rewrite up_decompose.
      now apply bounded_S_quant.
  Qed.

  Lemma subst_forall_prv phi {N Gamma} :
    Gamma ⊢ (forall_times N phi) -> bounded N phi -> forall sigma, Gamma ⊢ phi[sigma].
  Proof.
    induction N in phi |-*; intros ?? sigma; cbn in *.
    - change sigma with (iter up 0 sigma).
      now rewrite (subst_bounded 0).
    - specialize (IHN (∀ phi) ).
      rewrite <-up_decompose.
      apply AllE. apply IHN. unfold forall_times.
      now rewrite <-iter_switch.
      now apply bounded_S_quant.
  Qed.

  Lemma prv_cut A B phi :
    A ⊢ phi -> (forall psi, psi el A -> B ⊢ psi) -> B ⊢ phi.
  Proof.
    induction A in phi |- *; intros H1 H2.
    - eapply Weak; eauto.
    - rewrite <- imps in H1. apply IHA in H1; auto. apply IE with a; trivial. now apply H2.
  Qed.

  Lemma prv_intu_peirce T φ : T ⊢I φ -> T ⊢ φ.
  Proof using.
    remember intu. induction 1. all: now eauto.
  Qed.

End ND_def.

Local Hint Constructors prv : core.

(* ** Custom induction principle *)

Lemma prv_ind_full {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} :
  forall P : peirce -> list (form falsity_on) -> (form falsity_on) -> Prop,
    (forall (p : peirce) (A : list form) (phi psi : form),
        (phi :: A) ⊢ psi -> P p (phi :: A) psi -> P p A (phi → psi)) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ phi → psi -> P p A (phi → psi) -> A ⊢ phi -> P p A phi -> P p A psi) ->
    (forall (p : peirce) (A : list form) (phi : form),
        (map (subst_form ↑) A) ⊢ phi -> P p (map (subst_form ↑) A) phi -> P p A (∀ phi)) ->
    (forall (p : peirce) (A : list form) (t : term) (phi : form),
        A ⊢ ∀ phi -> P p A (∀ phi) -> P p A phi[t..]) ->
    (forall (p : peirce) (A : list form) (t : term) (phi : form),
        A ⊢ phi[t..] -> P p A phi[t..] -> P p A (∃ phi)) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ ∃ phi ->
              P p A (∃ phi) ->
              (phi :: [p[↑] | p ∈ A]) ⊢ psi[↑] -> P p (phi :: [p[↑] | p ∈ A]) psi[↑] -> P p A psi) ->
    (forall (p : peirce) (A : list form) (phi : form), A ⊢ ⊥ -> P p A ⊥ -> P p A phi) ->
    (forall (p : peirce) (A : list form) (phi : form), phi el A -> P p A phi) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ phi -> P p A phi -> A ⊢ psi -> P p A psi -> P p A (phi ∧ psi)) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ phi ∧ psi -> P p A (phi ∧ psi) -> P p A phi) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ phi ∧ psi -> P p A (phi ∧ psi) -> P p A psi) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ phi -> P p A phi -> P p A (phi ∨ psi)) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ psi -> P p A psi -> P p A (phi ∨ psi)) ->
    (forall (p : peirce) (A : list form) (phi psi theta : form),
        A ⊢ phi ∨ psi ->
        P p A (phi ∨ psi) ->
        (phi :: A) ⊢ theta ->
        P p (phi :: A) theta -> (psi :: A) ⊢ theta -> P p (psi :: A) theta -> P p A theta) ->
    (forall (A : list form) (phi psi : form), P class A (((phi → psi) → phi) → phi)) ->
    forall (p : peirce) (l : list form) (f14 : form), l ⊢ f14 -> P p l f14.
Proof.
  intros. specialize (@prv_ind _ _ (fun ff => match ff with falsity_on => P | _ => fun _ _ _ => True end)). intros H'.
  apply H' with (ff := falsity_on); clear H'. all: intros; try destruct ff; trivial. all: intuition eauto 2.
Qed.

(* ** Rudimentary tactics for ND manipulations *)

Ltac subsimpl_in H :=
  rewrite ?up_term, ?subst_term_shift in H.

Ltac subsimpl :=
  rewrite ?up_term, ?subst_term_shift.

Ltac assert1 H :=
  match goal with |- (?phi :: ?T) ⊢ _ => assert (H : (phi :: T) ⊢ phi) by auto end.

Ltac assert2 H :=
  match goal with |- (?phi :: ?psi :: ?T) ⊢ _ => assert (H : (phi :: psi :: T) ⊢ psi) by auto end.

Ltac assert3 H :=
  match goal with |- (?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (phi :: psi :: theta :: T) ⊢ theta) by auto end.

Ltac assert4 H :=
  match goal with |- (?f :: ?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (f :: phi :: psi :: theta :: T) ⊢ theta) by auto end.

Ltac prv_all x :=
  apply AllI; edestruct (@nameless_equiv_all) as [x ->]; cbn; subsimpl.

Ltac use_exists H x :=
  apply (ExE H); edestruct (@nameless_equiv_ex) as [x ->]; cbn; subsimpl.

(* ** Enumerability of proofs *)

Section Enumerability.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Variable list_Funcs : nat -> list syms.
  Hypothesis enum_Funcs' : list_enumerator__T list_Funcs syms.

  Variable list_Preds : nat -> list preds.
  Hypothesis enum_Preds' : list_enumerator__T list_Preds preds.

  Hypothesis eq_dec_Funcs : eq_dec syms.
  Hypothesis eq_dec_Preds : eq_dec preds.

  Instance eqdec_binop : eq_dec binop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Instance eqdec_quantop : eq_dec quantop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Definition list_binop (n : nat) := [Conj; Impl; Disj].

  Instance enum_binop :
    list_enumerator__T list_binop binop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Definition list_quantop (n : nat) := [All; Ex].

  Instance enum_quantop :
    list_enumerator__T list_quantop quantop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Lemma enumT_binop :
    enumerable__T binop.
  Proof.
    apply enum_enumT. exists list_binop. apply enum_binop.
  Qed.

  Lemma enumT_quantop :
    enumerable__T quantop.
  Proof.
    apply enum_enumT. exists list_quantop. apply enum_quantop.
  Qed.

  Instance enum_term' :
    list_enumerator__T (L_term _) term :=
    enum_term _.

  Instance enum_form' {ff : falsity_flag} :
    list_enumerator__T (L_form _ _ _ _) form :=
    enum_form _ _ _ _.

  Fixpoint L_ded {p : peirce} {b : falsity_flag} (A : list form) (n : nat) : list form :=
    match n with
    | 0 => A
    | S n =>   L_ded A n ++
    (* II *)   concat ([ [ phi → psi | psi ∈ L_ded (phi :: A) n ] | phi ∈ L_T form n ]) ++
    (* IE *)   [ psi | (phi, psi) ∈ (L_ded A n × L_T form n) , (phi → psi el L_ded A n) ] ++
    (* AllI *) [ ∀ phi | phi ∈ L_ded (map (subst_form ↑) A) n ] ++
    (* AllE *) [ phi[t..] | (phi, t) ∈ (L_T form n × L_T term n), (∀ phi) el L_ded A n ] ++
    (* ExI *)  [ ∃ phi | (phi, t) ∈ (L_T form n × L_T term n), (phi[t..]) el L_ded A n ] ++
    (* ExE *)  [ psi | (phi, psi) ∈ (L_T form n × L_T form n),
                     (∃ phi) el L_ded A n /\ psi[↑] el L_ded (phi::(map (subst_form ↑) A)) n ] ++
    (* Exp *)  (match b with falsity_on => fun A =>
                [ phi | phi ∈ L_T form n, ⊥ el @L_ded _ falsity_on A n ]
                | _ => fun _ => nil end A) ++
    (* Pc *)   (if p then
                [ (((phi → psi) → phi) → phi) | (pair phi psi) ∈ (L_T form n × L_T form n)]
                else nil) ++
    (* CI *)   [ phi ∧ psi | (phi, psi) ∈ (L_ded A n × L_ded A n) ] ++
    (* CE1 *)  [ phi | (phi, psi) ∈ (L_T form n × L_T form n), phi ∧ psi el L_ded A n] ++
    (* CE2 *)  [ psi | (phi, psi) ∈ (L_T form n × L_T form n), phi ∧ psi el L_ded A n] ++
    (* DI1 *)  [ phi ∨ psi | (phi, psi) ∈ (L_T form n × L_T form n), phi el L_ded A n] ++
    (* DI2 *)  [ phi ∨ psi | (phi, psi) ∈ (L_T form n × L_T form n), psi el L_ded A n] ++
    (* DE *)   [ theta | (phi, (psi, theta)) ∈ (L_T form n × (L_T form n × L_T form n)),
                     theta el L_ded (phi::A) n /\ theta el L_ded (psi::A) n /\ phi ∨ psi el L_ded A n]
    end.

  Opaque in_dec.

  Lemma enum_prv {p : peirce} {b : falsity_flag} A :
    list_enumerator (L_ded A) (prv A).
  Proof with try (eapply cum_ge'; eauto; lia).
    split.
    - rename x into phi. induction 1; try congruence; subst.
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 2.
        eapply in_concat_iff. eexists. split. 2:in_collect phi... in_collect psi...
      + destruct IHprv1 as [m1], IHprv2 as [m2], (el_T psi) as [m3]; eauto.
        exists (1 + m1 + m2 + m3).
        cbn. in_app 3. in_collect (phi, psi)...
      + destruct IHprv as [m]. exists (1 + m). cbn. in_app 4. in_collect phi...
      + destruct IHprv as [m1], (el_T t) as [m2], (el_T phi) as [m3]. exists (1 + m1 + m2 + m3).
        cbn. in_app 5. in_collect (phi, t)...
      + destruct IHprv as [m1], (el_T t) as [m2], (el_T phi) as [m3]. exists (1 + m1 + m2 + m3).
        cbn. in_app 6. in_collect (phi, t)...
      + destruct IHprv1 as [m1], IHprv2 as [m2], (el_T phi) as [m4], (el_T psi) as [m5].
        exists (1 + m1 + m2 + m4 + m5). cbn. in_app 7. cbn. in_collect (phi, psi)...
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 8. in_collect phi...
      + now exists 0.
      + destruct IHprv1 as [m1], IHprv2 as [m2]. exists (1 + m1 + m2). cbn. in_app 10. in_collect (phi, psi)...
      + destruct IHprv as [m1], (el_T phi) as [m2], (el_T psi) as [m3].
        exists (1 + m1 + m2 + m3). cbn. in_app 11. in_collect (phi, psi)...
      + destruct IHprv as [m1], (el_T phi) as [m2], (el_T psi) as [m3].
        exists (1 + m1 + m2 + m3). cbn. in_app 12. in_collect (phi, psi)...
      + destruct IHprv as [m1], (el_T phi) as [m2], (el_T psi) as [m3].
        exists (1 + m1 + m2 + m3). cbn. in_app 13. in_collect (phi, psi)...
      + destruct IHprv as [m1], (el_T phi) as [m2], (el_T psi) as [m3].
        exists (1 + m1 + m2 + m3). cbn. in_app 14. in_collect (phi, psi)...
      + destruct IHprv1 as [m1], IHprv2 as [m2], IHprv3 as [m3], (el_T phi) as [m4], (el_T psi) as [m5], (el_T theta) as [m6].
        exists (1 + m1 + m2 + m3 + m4 + m5 + m6). cbn. in_app 15. cbn. in_collect (phi, (psi, theta))...
      + destruct (el_T phi) as [m1], (el_T psi) as [m2]. exists (1 + m1 + m2). cbn. in_app 9. in_collect (phi, psi)...
    - intros [m]; induction m in A, x, H |-*; cbn in *.
      + now apply Ctx.
      + destruct p, b; inv_collect. all: eauto 3.
        * eapply IE; apply IHm; eauto.
        * eapply ExE; apply IHm; eauto.
        * eapply DE; apply IHm; eauto.
        * eapply IE; apply IHm; eauto.
        * eapply ExE; apply IHm; eauto.
        * eapply DE; apply IHm; eauto.
        * eapply IE; apply IHm; eauto.
        * eapply ExE; apply IHm; eauto.
        * eapply DE; apply IHm; eauto.
        * eapply IE; apply IHm; eauto.
        * eapply ExE; apply IHm; eauto.
        * eapply DE; apply IHm; eauto.
  Qed.

  Fixpoint L_con `{falsity_flag} (L : nat -> list form) (n : nat) : list (list form) :=
    match n with
    | 0 => [ nil ]
    | S n => L_con L n ++ [ phi :: A | (pair phi A) ∈ (L n × L_con L n) ]
    end.

  Lemma enum_el X (p : X -> Prop) L x :
    list_enumerator L p -> p x -> exists m, x el L m.
  Proof.
    firstorder.
  Qed.
  Arguments enum_el {X p L} x _ _.

  Lemma enum_p X (p : X -> Prop) L x m :
    list_enumerator L p -> x el L m -> p x.
  Proof.
    firstorder.
  Qed.

  Definition containsL `{falsity_flag} A (T : form -> Prop) :=
    forall psi, psi el A -> T psi.

  Lemma enum_containsL `{falsity_flag} T L :
    cumulative L -> list_enumerator L T -> list_enumerator (L_con L) (fun A => containsL A T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros HL He. split.
    - induction x as [| phi A]; intros HT.
      + exists 0. firstorder.
      + destruct IHA as [m1], (enum_el phi He) as [m2]. 1,2,3: firstorder.
        exists (1 + m1 + m2). cbn. in_app 2. in_collect (phi, A)...
    - intros [m]. induction m in x, H0 |-*; cbn in *.
      + destruct H0 as [<- | []]. firstorder.
      + inv_collect. apply IHm in H2. apply (enum_p He) in H0. unfold containsL in *. firstorder congruence.
  Qed.

  Fixpoint L_tded {p : peirce} {b : falsity_flag} (L : nat -> list form) (n : nat) : list form :=
    match n with
    | 0 => nil
    | S n => L_tded L n ++ concat ([ L_ded A n | A ∈ L_con L n ])
    end.

  Lemma enum_tprv {p : peirce} {b : falsity_flag} T L :
    list_enumerator L T -> list_enumerator (L_tded (cumul L)) (tprv T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros He.
    assert (HL : list_enumerator (cumul L) T) by now apply list_enumerator_to_cumul.
    split.
    - intros (A & [m1] % (enum_el A (@enum_containsL _ _ (cumul L) (to_cumul_cumulative L) HL)) & [m2] % (enum_el x (enum_prv A))).
      exists (1 + m1 + m2). cbn. in_app 2. eapply in_concat_iff. eexists. split. 2: in_collect A... idtac...
    - intros [m]. induction m in x, H |-*; cbn in *. 1: contradiction. inv_collect. exists x1. split.
      + eapply (enum_p (enum_containsL (to_cumul_cumulative L) HL)); eauto.
      + eapply (enum_p (enum_prv x1)); eassumption.
  Qed.

End Enumerability.

Section TheoryManipulation.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.
  Context {HF : eq_dec syms} {HP : eq_dec preds}.
  Lemma prv_T_impl T phi psi :
    (T ⋄ phi) ⊢T psi -> T ⊢T (phi → psi).
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2). exists (remove (dec_form _ _ _ _) phi A); split.
    - intros f [[] % HA1 Hf2] % in_remove; subst; intuition.
    - eapply II, Weak. 1: apply HA2. transitivity (phi :: A). 1: eauto. intros a [-> | Ha].
      + now left.
      + destruct (dec_form _ _ _ _ a phi) as [->|Hr]. 1:now left.
        right. now eapply in_in_remove.
  Qed.

  Lemma prv_T_remove T phi psi :
    T ⊢T phi -> T ⋄ phi ⊢T psi -> T ⊢T psi.
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2) (B & HB1 & HB2) % prv_T_impl.
    use_theory (A ++ B).
    - now intros psi1 [H1|H2]%in_app_iff; [apply HA1 | apply HB1].
    - eapply IE; eapply Weak. 1,3: eassumption.
      all: intros x Hx; apply in_app_iff; eauto.
  Qed.

  Lemma prv_T_comp T phi psi xi :
    T ⋄ phi ⊢T xi -> T ⋄ psi ⊢T phi -> T ⋄ psi ⊢T xi.
  Proof using HF HP.
    intros (A & HA1 & HA2) % prv_T_impl (B & HB1 & HB2) % prv_T_impl.
    use_theory (psi :: A ++ B).
    - now intros psi1 [->|[H1|H2]%in_app_iff]; [now right | |]; left; [apply HA1 | apply HB1].
    - eapply IE. 1: eapply Weak. 1: apply HA2. 2: eapply IE.
      2-3: eapply Weak. 2: eapply HB2. 3: apply (@Ctx _ _ _ _ (psi::nil)); now left.
      + intros a Ha; right; apply in_app_iff; now left.
      + intros b Hb; right; apply in_app_iff; now right.
      + intros x [->|[]]; now left.
  Qed.

  Lemma elem_prv T phi :
    phi ∈ T -> T ⊢T phi.
  Proof.
    intros ?. use_theory [phi]. 2:apply Ctx; now left.
    intros psi [->|[]]. apply H.
  Qed.

  Lemma Weak_T T1 T2 phi :
    T1 ⊢T phi -> T1 ⊑ T2 -> T2 ⊢T phi.
  Proof.
    intros (A & HA1 & HA2) HT2. exists A. split. 2:easy. intros psi H; now apply HT2, HA1.
  Qed.
End TheoryManipulation.

Section Closedness.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.

  Definition capture_subs n x := $(x + n).

  Lemma capture_extract n A phi :
    A ⊢ subst_form (capture_subs n) (capture All n phi) -> A ⊢ subst_form (capture_subs 0) phi.
  Proof.
    induction n; comp; intuition. apply IHn. apply (AllE (var n)) in H. rewrite subst_comp in H.
    erewrite subst_ext. 1: apply H. intros [| x]; unfold capture_subs; cbn; f_equal; lia.
  Qed.

  Context {Funcs_eq_dec : eq_dec Σ_funcs}.
  Context {Preds_eq_dec : eq_dec Σ_preds}.

  Lemma close_extract A phi :
    A ⊢ close All phi -> A ⊢ phi.
  Proof.
    intros H. assert (Hclosed : closed (close All phi)) by apply close_closed.
    unfold close in *. destruct (find_bounded phi) as [n Hn]; cbn in *.
    erewrite <- subst_id with (sigma := fun x => $x) in H.
    erewrite (@bounded_subst _ _ _ _ _ _ _ (capture_subs n)) in H.
    2: exact Hclosed. 3:easy. 2: lia.
    apply capture_extract in H. rewrite subst_id in H; intuition. unfold capture_subs. f_equal. lia.
  Qed.

End Closedness.

Section DNFacts.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Lemma DN A phi: A ⊢C (¬ (¬ phi)) -> A ⊢C phi.
  Proof.
    intros H. eapply IE. 1: apply Pc. eapply II.
    apply Exp. eapply IE. 2: apply Ctx; now left.
    eapply Weak. 1: apply H. intros a Ha; now right.
  Qed.

  Lemma XMc A (phi chi : form) : (phi::A) ⊢C chi -> ((¬ phi)::A) ⊢C chi -> A ⊢C chi.
  Proof.
    intros HA HB. eapply IE with ((phi → chi) → (¬phi → chi) → chi).
    - eapply II. eapply IE. 1: eapply IE. 1: apply Ctx; now left.
      1-2: eapply Weak; [eapply II|]. 1: apply HA. 2: apply HB. 1-2: intros a Ha; now right.
    - eapply DN. apply II. eapply IE. 1: apply Ctx; now left. eapply II. eapply II.
      eapply IE. 1: apply Ctx; now left.
      eapply II. eapply IE. 1: apply Ctx; do 3 right; now left. do 2 eapply II.
      eapply IE. 1: apply Ctx; right; now left.
      apply Ctx; now eauto.
  Qed.

  Lemma XM A (phi : form) : A ⊢C (phi ∨ ¬ phi).
  Proof.
    apply (@XMc _ phi).
    - apply DI1, Ctx. now left.
    - apply DI2, Ctx. now left.
  Qed.

End DNFacts.

Section RefutationComp.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.
  Context {HF : eq_dec Σ_funcs} {HP : eq_dec Σ_preds}.

  Lemma refutation_prv T phi :
    T ⊢TC phi <-> (T ⋄ ¬ phi) ⊢TC ⊥.
  Proof using HF HP.
    split.
    - intros (A & HA1 & HA2). use_theory (¬ phi :: A).
      + intros psi [<-|Ha]. 1: now right. left. now apply HA1.
      + eapply IE. 1: apply Ctx; now left. eapply Weak. 1: apply HA2. intros a Ha; now right.
    - intros (A & HA1 & HA2) % prv_T_impl. use_theory A. now apply DN.
  Qed.
End RefutationComp.


Require Import HoTT.Types.Universe.
Require Import
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.orders.nat_int
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.groups
  HoTT.Classes.orders.rings.

Generalizable Variables N Z Zle Zlt R f.

Section contents.
Context `{Funext} `{Univalence}.
Context `{Integers Z} `{Apart Z} `{!TrivialApart Z}
  `{!FullPseudoSemiRingOrder Zle Zlt} `{Naturals N}.

(* Add Ring Z : (rings.stdlib_ring_theory Z). *)

Lemma int_abs_unique (a b : IntAbs Z N) (z : Z) :
  int_abs Z N (ia:=a) z = int_abs Z N (ia:=b) z.
Proof.
unfold int_abs.
destruct (int_abs_sig Z N (IntAbs:=a) z) as [[n1 E1]|[n1 E1]];
destruct (int_abs_sig Z N (IntAbs:=b) z) as [[n2 E2]|[n2 E2]].
- apply (injective (naturals_to_semiring N Z)). path_via z.
- assert (E : n1 + n2 = 0);[|path_via 0;[|symmetry];
  apply (naturals.zero_sum _ _ E)].
  apply (injective (naturals_to_semiring N Z)).
  rewrite preserves_0,preserves_plus.
  rewrite E1,E2.
  apply plus_negate_r.
- assert (E : n1 + n2 = 0);[|path_via 0;[|symmetry];
  apply (naturals.zero_sum _ _ E)].
  apply (injective (naturals_to_semiring N Z)).
  rewrite preserves_0,preserves_plus.
  rewrite E1,E2.
  apply plus_negate_l.
- apply (injective (naturals_to_semiring N Z)). path_via (- z).
Qed.

Context `{!IntAbs Z N}.

Context `{!IsSemiRingPreserving (f : N -> Z)}.

Lemma int_abs_spec x :
  (0 ≤ x /\ f (int_abs Z N x) = x) |_| (x ≤ 0 /\ f (int_abs Z N x) = -x).
Proof.
unfold int_abs. destruct (int_abs_sig Z N x) as [[n E]|[n E]].
- left. rewrite <-E. split.
  + eapply @to_semiring_nonneg;apply _.
  + apply (naturals.to_semiring_unique_alt _ _).
- right. split.
  + apply flip_nonpos_negate. rewrite <-E. eapply @to_semiring_nonneg;apply _.
  + rewrite <-E. apply (naturals.to_semiring_unique_alt _ _).
Qed.

Lemma int_abs_sig_alt x :
  (sig (fun n : N => f n = x)) |_| (sig (fun n : N => f n = - x)).
Proof. destruct (int_abs_spec x) as [[??]|[??]]; eauto. Qed.

Lemma int_abs_nat n :
  int_abs Z N (f n) = n.
Proof.
apply (injective f).
destruct (int_abs_spec (f n)) as [[? E]|[? E]];trivial.
apply naturals.negate_to_ring. rewrite E, involutive. trivial.
Qed.

Lemma int_abs_negate_nat n :
  int_abs Z N (-f n) = n.
Proof.
apply (injective f). destruct (int_abs_spec (-f n)) as [[? E]|[? E]].
- symmetry. apply naturals.negate_to_ring. apply symmetry; trivial.
- rewrite involutive in E. trivial.
Qed.

Lemma int_abs_negate x :
  int_abs Z N (-x) = int_abs Z N x.
Proof.
destruct (int_abs_spec x) as [[_ E]|[_ E]].
- path_via (int_abs Z N (- f (int_abs Z N x))).
  apply int_abs_negate_nat.
- rewrite <-E. apply int_abs_nat.
Qed.

Lemma int_abs_0_alt x : int_abs Z N x = 0 <-> x = 0.
Proof.
split; intros E1.
- destruct (int_abs_spec x) as [[_ E2]|[_ E2]];[|apply flip_negate_0];
  rewrite <-E2, E1, (preserves_0 (f:=f)); trivial.
- rewrite E1, <-(preserves_0 (f:=f)). apply int_abs_nat.
Qed.

Lemma int_abs_ne_0 x : int_abs Z N x <> 0 <-> x <> 0.
Proof.
destruct (int_abs_0_alt x).
split;intros E1 E2;auto.
Qed.

Lemma int_abs_0 : int_abs Z N 0 = 0.
Proof. apply int_abs_0_alt;trivial. Qed.

Lemma int_abs_nonneg x :
  0 ≤ x -> f (int_abs Z N x) = x.
Proof.
intros E1. destruct (int_abs_spec x) as [[n E2]|[n E2]];trivial.
assert (Hrw : x = 0).
- apply (antisymmetry (<=));trivial.
- rewrite Hrw,int_abs_0, (preserves_0 (f:=f)). trivial.
Qed.

Lemma int_abs_nonpos x :
  x ≤ 0 -> f (int_abs Z N x) = -x.
Proof.
intros E. rewrite <-int_abs_negate, int_abs_nonneg; auto.
apply flip_nonpos_negate. trivial.
Qed.

Lemma int_abs_1 : int_abs Z N 1 = 1.
Proof.
apply (injective f). rewrite (preserves_1 (f:=f)).
apply int_abs_nonneg; solve_propholds.
Qed.

Lemma int_abs_nonneg_plus x y :
  0 ≤ x -> 0 ≤ y -> int_abs Z N (x + y) = int_abs Z N x + int_abs Z N y.
Proof.
intros. apply (injective f).
rewrite (preserves_plus (f:=f)), !int_abs_nonneg;auto.
apply nonneg_plus_compat;trivial.
Qed.

Lemma int_abs_mult x y :
  int_abs Z N (x * y) = int_abs Z N x * int_abs Z N y.
Proof.
apply (injective f). rewrite (preserves_mult (f:=f)).
destruct (int_abs_spec x) as [[? Ex]|[? Ex]],
   (int_abs_spec y) as [[? Ey]|[? Ey]]; rewrite Ex, Ey.
- rewrite int_abs_nonneg;trivial. apply nonneg_mult_compat;trivial.
- rewrite int_abs_nonpos.
  + apply negate_mult_distr_r.
  + apply nonneg_nonpos_mult;trivial.
- rewrite int_abs_nonpos.
  + apply negate_mult_distr_l.
  + apply nonpos_nonneg_mult;trivial.
- rewrite int_abs_nonneg.
  + symmetry;apply negate_mult_negate.
  + apply nonpos_mult;trivial.
Qed.
End contents.


Require Import Program.Tactics.

Obligation Tactic := idtac.
Set Universe Polymorphism.

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Inductive Empty : Type :=.
Inductive Unit : Type := tt.
Definition not (A : Type) := A -> Empty.

  Lemma nat_path_O_S (n : nat) (H : paths O (S n)) : Empty.
  Proof. refine (
    match H in paths _ i return
      match i with
      | O => Unit
      | S _ => Empty
      end
    with
    | idpath _ => tt
    end
  ). Defined.
  Lemma symmetry {A} (x y : A) (p : paths x y) : paths y x.
  Proof.
    destruct p. apply idpath.
  Defined.
  Lemma nat_path_S_O (n : nat) (H : paths (S n) O) : Empty.
  Proof. eapply nat_path_O_S. exact (symmetry _ _ H). Defined.
Set Printing Universes.
Program Fixpoint succ_not_zero (n:nat) : not (paths (S n) 0) :=
match n as n return not (paths (S n) 0) with
| 0 => nat_path_S_O _
| S n' => let dummy := succ_not_zero n' in _
end.
Next Obligation.
  intros f _ n dummy H. exact (nat_path_S_O _ H).
  Show Universes.
Defined.


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

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

Print Assumptions sub.


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

 Cartesian 1-cells

 In this file, we show that if we have 2 cartesian 1-cells over some
 1-cell, then we have an adjoint equivalence between their domains.

 *********************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Opposite.
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.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.TransportLaws.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispPseudofunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.Display.StrictPseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.StrictPseudoFunctor.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.StrictToPseudo.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.

Local Open Scope cat.
Local Open Scope mor_disp.

Section AdjEquivBetweenCartesian.
  Context {B : bicat}
          {D : disp_bicat B}
          (HB_2_1 : is_univalent_2_1 B).

  Section MapAndCellFromCartesians.
    Context {x y : B}
            {f : x --> y}
            {xx₁ xx₂ : D x}
            {yy : D y}
            (ff₁ : xx₁ -->[ f ] yy)
            {ff₂ : xx₂ -->[ f ] yy}
            (Hff₂ : cartesian_1cell D ff₂).

    Let ff' : xx₁ -->[ id₁ x · f ] yy
      := transport_along_inv_2cell
           HB_2_1
           (linvunitor_invertible_2cell f)
           ff₁.
    Let ℓ : lift_1cell_factor D ff₂ ff'
      := pr1 Hff₂ x xx₁ (id₁ _) ff'.

    Definition map_between_cartesian_1cell
      : xx₁ -->[ id₁ _ ] xx₂
      := ℓ.

    Definition map_between_cartesian_1cell_commute
      : disp_invertible_2cell
          (lunitor_invertible_2cell _)
          (map_between_cartesian_1cell ;; ff₂)
          ff₁.
    Proof.
      refine (transportf
                (λ z, disp_invertible_2cell z _ _)
                _
                (vcomp_disp_invertible
                   (pr2 ℓ)
                   (transport_along_inv_2cell_disp_invertible_2cell _ _ _))).
      abstract
        (use subtypePath ; [ intro ; apply isaprop_is_invertible_2cell | ] ;
         cbn ;
         apply id2_left).
    Defined.
  End MapAndCellFromCartesians.

  Section InverseOfCartesians.
    Context {x y : B}
            {f : x --> y}
            {xx₁ xx₂ : D x}
            {yy : D y}
            {ff₁ : xx₁ -->[ f ] yy}
            (Hff₁ : cartesian_1cell D ff₁)
            {ff₂ : xx₂ -->[ f ] yy}
            (Hff₂ : cartesian_1cell D ff₂).

    Let l : xx₁ -->[ id₁ x] xx₂
      := map_between_cartesian_1cell ff₁ Hff₂.

    Let δl : disp_invertible_2cell
               (lunitor_invertible_2cell f)
               (l ;; ff₂)
               ff₁
      := map_between_cartesian_1cell_commute ff₁ Hff₂.

    Let r : xx₂ -->[ id₁ x] xx₁
      := map_between_cartesian_1cell ff₂ Hff₁.

    Let δr : disp_invertible_2cell
               (lunitor_invertible_2cell f)
               (r ;; ff₁)
               ff₂
      := map_between_cartesian_1cell_commute ff₂ Hff₁.

    Let gg₁ : xx₂ -->[ id₁ x · f ] yy
      := transport_along_inv_2cell
           HB_2_1
           (linvunitor_invertible_2cell f)
           ff₂.

    Let γ₁ : disp_invertible_2cell
               (inv_of_invertible_2cell (linvunitor_invertible_2cell f))
               gg₁
               ff₂
      := transport_along_inv_2cell_disp_invertible_2cell
           HB_2_1
           (linvunitor_invertible_2cell f)
           ff₂.

    Let gg₂ : xx₂ -->[ id₁ x · id₁ x · f ] yy
      := transport_along_inv_2cell
           HB_2_1
           (comp_of_invertible_2cell
              (comp_of_invertible_2cell
                 (linvunitor_invertible_2cell _)
                 (linvunitor_invertible_2cell _))
              (lassociator_invertible_2cell _ _ _))
           ff₂.

    Let γ₂ : disp_invertible_2cell _ gg₂ ff₂
      := transport_along_inv_2cell_disp_invertible_2cell
           HB_2_1
           (comp_of_invertible_2cell
              (comp_of_invertible_2cell
                 (linvunitor_invertible_2cell _)
                 (linvunitor_invertible_2cell _))
              (lassociator_invertible_2cell _ _ _))
           ff₂.

    Local Lemma first_lift_path
      : comp_of_invertible_2cell
          (lunitor_invertible_2cell f)
          (inv_of_invertible_2cell
             (inv_of_invertible_2cell
                (linvunitor_invertible_2cell f)))
        =
        id2_invertible_2cell (id₁ x · f).
    Proof.
      use subtypePath.
      {
        intro.
        apply isaprop_is_invertible_2cell.
      }
      cbn.
      apply lunitor_linvunitor.
    Qed.

    Local Definition first_lift
      : lift_1cell_factor D ff₂ gg₁.
    Proof.
      refine (id_disp _ ,, _).
      exact (transportf
               (λ z, disp_invertible_2cell z _ _)
               first_lift_path
               (vcomp_disp_invertible
                  (disp_invertible_2cell_lunitor _)
                  (inverse_of_disp_invertible_2cell γ₁))).
    Defined.

    Local Lemma second_lift_path
      : comp_of_invertible_2cell
          (rassociator_invertible_2cell _ _ _)
          (comp_of_invertible_2cell
             (lwhisker_of_invertible_2cell _ (lunitor_invertible_2cell _))
             (comp_of_invertible_2cell
                (lunitor_invertible_2cell f)
                (inv_of_invertible_2cell
                   (inv_of_invertible_2cell
                      (comp_of_invertible_2cell
                         (comp_of_invertible_2cell
                            (linvunitor_invertible_2cell _)
                            (linvunitor_invertible_2cell _))
                         (lassociator_invertible_2cell (id₁ x) (id₁ x) f))))))
        =
        id2_invertible_2cell (id₁ x · id₁ x · f).
    Proof.
      use subtypePath.
      {
        intro.
        apply isaprop_is_invertible_2cell.
      }
      cbn.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lunitor_linvunitor.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lunitor_lwhisker.
      rewrite !vassocl.
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      rewrite rassociator_lassociator.
      rewrite id2_right.
      rewrite runitor_lunitor_identity.
      rewrite rwhisker_vcomp.
      rewrite lunitor_linvunitor.
      apply id2_rwhisker.
    Qed.

    Local Definition second_lift
      : lift_1cell_factor D ff₂ gg₂.
    Proof.
      refine (r ;; l ,, _).
      exact (transportf
               (λ z, disp_invertible_2cell z _ _)
               second_lift_path
               (vcomp_disp_invertible
                  (disp_invertible_2cell_rassociator _ _ _)
                  (vcomp_disp_invertible
                     (disp_invertible_2cell_lwhisker r δl)
                     (vcomp_disp_invertible
                        δr
                        (inverse_of_disp_invertible_2cell γ₂))))).
    Defined.

    Local Definition help_cell₁
      : gg₂ ==>[ lunitor (id₁ x) ▹ f] gg₁.
    Proof.
      refine (transportf
                (λ z, _ ==>[ z ] _)
                _
                (γ₂ •• disp_inv_cell γ₁)).
      abstract
        (cbn ;
         rewrite !vassocl ;
         rewrite lunitor_linvunitor ;
         rewrite id2_right ;
         rewrite <- lunitor_triangle ;
         rewrite !vassocr ;
         rewrite rassociator_lassociator ;
         apply id2_left).
    Defined.

    Let w₁ : lift_2cell_factor D ff₂ help_cell₁ second_lift first_lift
      := pr2 Hff₂ x xx₂ _ _ _ gg₁ (lunitor (id₁ x)) help_cell₁ second_lift first_lift.

    Definition disp_adj_equiv_between_cartesian_1cell_inv
      : r ;; l ==>[ lunitor _ ] id_disp _
      := w₁.

    Let ζ : r ;; l ==>[ lunitor _ ] id_disp _
      := disp_adj_equiv_between_cartesian_1cell_inv.

    Local Definition help_cell₂
      : gg₁ ==>[ linvunitor (id₁ x) ▹ f] gg₂.
    Proof.
      refine (transportf
                (λ z, _ ==>[ z ] _)
                _
                (γ₁ •• disp_inv_cell γ₂)).
      abstract
        (cbn ;
         rewrite !vassocr ;
         rewrite lunitor_linvunitor ;
         rewrite id2_left ;
         rewrite rwhisker_hcomp ;
         rewrite lunitor_V_id_is_left_unit_V_id ;
         rewrite <- triangle_l_inv ;
         rewrite <- lwhisker_hcomp ;
         apply maponpaths_2 ;
         rewrite linvunitor_assoc ;
         rewrite lwhisker_hcomp ;
         rewrite triangle_r_inv ;
         rewrite <- rwhisker_hcomp ;
         rewrite lunitor_V_id_is_left_unit_V_id ;
         apply idpath).
    Defined.

    Let w₂ : lift_2cell_factor D ff₂ help_cell₂ first_lift second_lift
      := pr2 Hff₂ x xx₂ _ _ _ gg₂ (linvunitor (id₁ x)) help_cell₂ first_lift second_lift.

    Definition inv_of_disp_adj_equiv_between_cartesian_1cell_inv
      : id_disp _ ==>[ linvunitor _ ] r ;; l
      := w₂.

    Let ξ : id_disp _ ==>[ linvunitor _ ] r ;; l
      := inv_of_disp_adj_equiv_between_cartesian_1cell_inv.

    Local Definition help_inv_cell₁
      : gg₂ ==>[ id₂ _ ▹ f ] gg₂
      := transportb
           (λ z, _ ==>[ z ] _)
           (id2_rwhisker _ _)
           (disp_id2 _).

    Local Lemma disp_adj_equiv_between_cartesian_inv₁
      : ζ •• ξ
        =
        transportb
          (λ z, r ;; l ==>[ z ] r ;; l)
          (vcomp_rinv (is_invertible_2cell_lunitor (id₁ x)))
          (disp_id2 (r ;; l)).
    Proof.
      refine (!(transportbfinv (λ z, _ ==>[ z ] _) (lunitor_linvunitor _) _) @ _).
      refine (_ @ transportbfinv (λ z, _ ==>[ z ] _) (lunitor_linvunitor _) _).
      apply maponpaths.
      use (isaprop_lift_of_lift_2cell
             _ _
             (pr2 Hff₂ _ _ _ _ _ _ _ help_inv_cell₁ second_lift second_lift)).
      - rewrite disp_rwhisker_transport_left_new.
        rewrite disp_mor_transportf_postwhisker.
        rewrite transport_f_f.
        rewrite disp_rwhisker_vcomp_alt.
        unfold transportb.
        rewrite disp_mor_transportf_postwhisker.
        rewrite transport_f_f.
        rewrite disp_vassocl.
        unfold transportb.
        rewrite transport_f_f.
        etrans.
        {
          do 2 apply maponpaths.
          exact (eq_lift_2cell_alt _ _ w₂).
        }
        unfold transportb.
        rewrite disp_mor_transportf_prewhisker.
        rewrite transport_f_f.
        unfold help_cell₂.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite transport_f_f.
        etrans.
        {
          apply maponpaths.
          refine (disp_vassocr _ _ _ @ _) ; apply maponpaths.
          apply maponpaths_2.
          exact (eq_lift_2cell_alt _ _ w₁).
        }
        unfold transportb.
        rewrite !disp_mor_transportf_postwhisker.
        rewrite !transport_f_f.
        unfold help_cell₁.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite disp_mor_transportf_postwhisker.
        rewrite transport_f_f.
        rewrite !disp_vassocl.
        unfold transportb.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite !transport_f_f.
        etrans.
        {
          do 3 apply maponpaths.
          refine (disp_vassocr _ _ _ @ _) ; apply maponpaths.
          rewrite disp_vcomp_linv.
          unfold transportb.
          rewrite disp_mor_transportf_postwhisker.
          rewrite disp_id2_left.
          unfold transportb.
          rewrite transport_f_f.
          apply idpath.
        }
        unfold transportb.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite !transport_f_f.
        etrans.
        {
          do 2 apply maponpaths.
          apply disp_vcomp_rinv.
        }
        unfold transportb.
        rewrite disp_mor_transportf_prewhisker.
        rewrite transport_f_f.
        etrans.
        {
          apply maponpaths.
          apply disp_id2_right.
        }
        unfold transportb.
        rewrite transport_f_f.
        unfold help_inv_cell₁.
        unfold transportb.
        rewrite disp_mor_transportf_prewhisker.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply disp_id2_right.
        }
        unfold transportb.
        rewrite transport_f_f.
        apply maponpaths_2.
        apply cellset_property.
      - unfold help_inv_cell₁, transportb.
        rewrite !disp_rwhisker_transport_left_new.
        rewrite !disp_mor_transportf_postwhisker.
        rewrite disp_mor_transportf_prewhisker.
        rewrite !transport_f_f.
        rewrite disp_id2_rwhisker.
        unfold transportb.
        rewrite disp_mor_transportf_postwhisker.
        rewrite !transport_f_f.
        rewrite disp_id2_left, disp_id2_right.
        unfold transportb.
        rewrite !transport_f_f.
        apply maponpaths_2.
        apply cellset_property.
    Qed.

    Local Definition help_inv_cell₂
      : gg₁ ==>[ id₂ (id₁ x) ▹ f ] gg₁
      := transportb
           (λ z, _ ==>[ z ] _)
           (id2_rwhisker _ _)
           (disp_id2 _).

    Local Lemma disp_adj_equiv_between_cartesian_inv₂
      : ξ •• ζ
        =
        transportb
          (λ z, id_disp xx₂ ==>[ z ] id_disp xx₂)
          (vcomp_linv (is_invertible_2cell_lunitor (id₁ x)))
          (disp_id2 (id_disp xx₂)).
    Proof.
      refine (!(transportbfinv (λ z, _ ==>[ z ] _) (linvunitor_lunitor _) _) @ _).
      refine (_ @ transportbfinv (λ z, _ ==>[ z ] _) (linvunitor_lunitor _) _).
      apply maponpaths.
      use (isaprop_lift_of_lift_2cell
             _ _
             (pr2 Hff₂ x _ _ _ _ _ _ help_inv_cell₂ first_lift first_lift)).
      - cbn.
        etrans.
        {
          do 2 apply maponpaths.
          exact (transportf_disp_invertible_2cell first_lift_path _).
        }
        cbn.
        rewrite disp_rwhisker_transport_left_new.
        rewrite !disp_mor_transportf_postwhisker.
        rewrite disp_mor_transportf_prewhisker.
        rewrite !transport_f_f.
        rewrite disp_rwhisker_vcomp_alt.
        rewrite disp_mor_transportf_postwhisker.
        rewrite transport_f_f.
        refine (!_).
        etrans.
        {
          apply maponpaths_2.
          exact (transportf_disp_invertible_2cell first_lift_path _).
        }
        cbn.
        rewrite disp_mor_transportf_postwhisker.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          refine (disp_vassocl _ _ _ @ _) ; apply maponpaths.
          apply maponpaths.
          pose (maponpaths
                  (λ z, _ •• z)
                  (!(transportf_disp_invertible_2cell first_lift_path _))
                @ eq_lift_2cell_alt _ _ w₁) as p.
          cbn in p.
          rewrite disp_mor_transportf_prewhisker in p.
          pose (p' := @transportb_transpose_right
                        _ (λ z, _ ==>[ z ] _)
                        _ _ _ _ _
                        p).
          exact p'.
        }
        unfold transportb.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite !transport_f_f.
        etrans.
        {
          do 2 apply maponpaths.
          apply maponpaths_2.
          exact (transportf_disp_invertible_2cell second_lift_path _).
        }
        cbn.
        rewrite disp_mor_transportf_postwhisker.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite transport_f_f.
        etrans.
        {
          apply maponpaths.
          refine (disp_vassocr _ _ _ @ _) ; apply maponpaths.
          apply maponpaths_2.
          pose (maponpaths
                  (λ z, _ •• z)
                  (!(transportf_disp_invertible_2cell second_lift_path _))
                @ eq_lift_2cell_alt _ _ w₂) as p.
          cbn in p.
          rewrite disp_mor_transportf_prewhisker in p.
          pose (p' := @transportb_transpose_right
                        _ (λ z, _ ==>[ z ] _)
                        _ _ _ _ _
                        p).
          exact p'.
        }
        unfold transportb.
        rewrite !disp_mor_transportf_postwhisker.
        rewrite !transport_f_f.
        etrans.
        {
          apply maponpaths.
          do 2 apply maponpaths_2.
          exact (transportf_disp_invertible_2cell first_lift_path _).
        }
        cbn.
        rewrite !disp_mor_transportf_postwhisker.
        rewrite !transport_f_f.
        unfold help_cell₂, help_cell₁.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite transport_f_f.
        rewrite !disp_vassocl.
        unfold transportb.
        rewrite !disp_mor_transportf_postwhisker.
        rewrite !transport_f_f.
        etrans.
        {
          apply maponpaths.
          refine (disp_vassocl _ _ _ @ _) ; apply maponpaths.
          apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            refine (disp_vassocr _ _ _ @ _) ; apply maponpaths.
            apply maponpaths_2.
            exact (disp_vcomp_linv γ₁).
          }
          unfold transportb.
          rewrite !disp_mor_transportf_postwhisker.
          rewrite transport_f_f.
          etrans.
          {
            apply maponpaths.
            apply maponpaths_2.
            apply disp_id2_left.
          }
          unfold transportb.
          rewrite disp_mor_transportf_postwhisker.
          rewrite transport_f_f.
          apply maponpaths.
          refine (disp_vassocr _ _ _ @ _) ; apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            exact (disp_vcomp_linv γ₂).
          }
          unfold transportb.
          rewrite disp_mor_transportf_postwhisker.
          apply maponpaths.
          apply disp_id2_left.
        }
        unfold transportb.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite !transport_f_f.
        unfold help_inv_cell₂.
        unfold transportb.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite transport_f_f.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          apply disp_id2_right.
        }
        unfold transportb.
        rewrite disp_mor_transportf_prewhisker.
        rewrite transport_f_f.
        apply maponpaths_2.
        apply cellset_property.
      - unfold help_inv_cell₂.
        unfold transportb.
        rewrite !disp_rwhisker_transport_left_new.
        rewrite !disp_mor_transportf_prewhisker.
        rewrite !disp_mor_transportf_postwhisker.
        rewrite !transport_f_f.
        rewrite disp_id2_rwhisker.
        unfold transportb.
        rewrite disp_mor_transportf_postwhisker.
        rewrite transport_f_f.
        rewrite disp_id2_left, disp_id2_right.
        unfold transportb.
        rewrite !transport_f_f.
        apply maponpaths_2.
        apply cellset_property.
    Qed.

    Definition disp_adj_equiv_between_cartesian_1cell_inv_is_invertible
      : is_disp_invertible_2cell (is_invertible_2cell_lunitor _) ζ
      := ξ
         ,,
         disp_adj_equiv_between_cartesian_inv₁
         ,,
         disp_adj_equiv_between_cartesian_inv₂.

    Definition disp_adj_equiv_between_cartesian_1cell_inv_2cell
      : disp_invertible_2cell (lunitor_invertible_2cell _) (r ;; l) (id_disp _).
    Proof.
      refine (ζ ,, _).
      apply disp_adj_equiv_between_cartesian_1cell_inv_is_invertible.
    Defined.
  End InverseOfCartesians.

  Section DispAdjEquivBetweenCartesians.
    Context {x y : B}
            {f : x --> y}
            {xx₁ xx₂ : D x}
            {yy : D y}
            {ff₁ : xx₁ -->[ f ] yy}
            (Hff₁ : cartesian_1cell D ff₁)
            {ff₂ : xx₂ -->[ f ] yy}
            (Hff₂ : cartesian_1cell D ff₂).

    Let l : xx₁ -->[ id₁ x] xx₂
      := map_between_cartesian_1cell ff₁ Hff₂.
    Let r : xx₂ -->[ id₁ x] xx₁
      := map_between_cartesian_1cell ff₂ Hff₁.

    Local Definition disp_adj_equiv_between_cartesian_1cell_unit
      : id_disp _ ==>[ linvunitor _ ] l ;; r.
    Proof.
      exact (pr1 (inverse_of_disp_invertible_2cell
                    (disp_adj_equiv_between_cartesian_1cell_inv_2cell Hff₂ Hff₁))).
    Defined.

    Let η : id_disp _ ==>[ linvunitor _ ] l ;; r
      := disp_adj_equiv_between_cartesian_1cell_unit.

    Local Definition disp_adj_equiv_between_cartesian_1cell_unit_invertible
      : is_disp_invertible_2cell (is_invertible_2cell_linvunitor _) η.
    Proof.
      refine (transportf
                (λ z, is_disp_invertible_2cell z _)
                _
                (pr2 (inverse_of_disp_invertible_2cell
                        (disp_adj_equiv_between_cartesian_1cell_inv_2cell
                           Hff₂ Hff₁)))).
      apply isaprop_is_invertible_2cell.
    Defined.

    Local Definition disp_adj_equiv_between_cartesian_1cell_counit
      : r ;; l ==>[ lunitor _ ] id_disp _
      := disp_adj_equiv_between_cartesian_1cell_inv Hff₁ Hff₂.

    Let ε : r ;; l ==>[ lunitor _ ] id_disp _
      := disp_adj_equiv_between_cartesian_1cell_counit.

    Local Definition disp_adj_equiv_between_cartesian_1cell_counit_invertible
      : is_disp_invertible_2cell (is_invertible_2cell_lunitor (id₁ x)) ε
      := disp_adj_equiv_between_cartesian_1cell_inv_is_invertible Hff₁ Hff₂.

    Definition disp_adj_equiv_between_cartesian_1cell
      : ∑ (e : left_adjoint_equivalence (id₁ x)),
        disp_left_adjoint_equivalence e l.
    Proof.
      use disp_left_equivalence_to_left_adjoint_equivalence.
      - exact (left_equivalence_of_left_adjoint_equivalence
                 (internal_adjoint_equivalence_identity x)).
      - refine ((r ,, η ,, ε) ,, _ ,, _).
        + exact disp_adj_equiv_between_cartesian_1cell_unit_invertible.
        + exact disp_adj_equiv_between_cartesian_1cell_counit_invertible.
    Defined.
  End DispAdjEquivBetweenCartesians.
End AdjEquivBetweenCartesian.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.ZUtil.ModInv.
Require Import Crypto.Util.SideConditions.CorePackages.

Local Open Scope Z_scope.

Definition modinv_evar_package (modinv_fuel : nat) (a modulus : Z)
  := evar_Prop_package
       (fun a' => (a * a') mod modulus = 1).

Ltac autosolve else_tac :=
  lazymatch goal with
  | [ |- modinv_evar_package ?modinv_fuel ?a ?modulus ]
    => let v0 := constr:(Option.invert_Some (Z.modinv_fueled modinv_fuel a modulus)) in
       let v := (eval vm_compute in v0) in
       let v := lazymatch type of v with (* if the computation failed, display a reasonable error message about the attempted computation *)
                | Z => v
                | _ => (eval cbv -[Option.invert_Some Z.modinv_fueled] in v0)
                end in
       let v := (eval vm_compute in (v <: Z)) in
       (exists v); vm_compute; reflexivity
  | _ => else_tac ()
  end.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


Require Import
  MathClasses.interfaces.abstract_algebra
  CoRN.stdlib_omissions.Q
  CoRN.algebra.RSetoid
  CoRN.metric2.Metric
  CoRN.metric2.UniformContinuity
  CoRN.reals.fast.CRpi_fast
  CoRN.reals.fast.CRarctan_small
  CoRN.reals.faster.ARarctan_small.

Section ARpi.
Context `{AppRationals AQ}.

Lemma AQpi_prf (x : Z) : 1 < x → -('x : AQ) < 1 < ('x : AQ).
Proof.
  split. 2: apply semirings.preserves_gt_1, H5.
  rewrite <- (rings.preserves_1 (f:=cast Z AQ)).
  rewrite <- (rings.preserves_negate (f:=cast Z AQ)).
  apply (strictly_order_preserving (cast Z AQ)).
  unfold one, stdlib_binary_integers.Z_1.
  rewrite <- (Z.opp_involutive 1).
  apply Z.gt_lt, CornBasics.Zlt_opp.
  apply (Z.lt_trans _ 1). reflexivity. exact H5.
Qed.

Lemma ZtoAQ_pos : forall (z:Z), 0 < z -> 0 < ('z : AQ).
Proof.
  intros z zpos.
  pose proof (rings.preserves_0 (f:=cast Z AQ)).
  rewrite <- H5.
  exact (strictly_order_preserving (cast Z AQ) 0 z zpos).
Qed.

Definition AQpi (x : AQ) : msp_car AR :=
  ucFun (ARscale (' 176%Z * x))
    (AQarctan_small (AQpi_prf 57 eq_refl) (ZtoAQ_pos 57 eq_refl)) +
  ucFun (ARscale (' 28%Z * x))
    (AQarctan_small (AQpi_prf 239 eq_refl) (ZtoAQ_pos 239 eq_refl)) +
  (ucFun (ARscale (' (-48)%Z * x))
     (AQarctan_small (AQpi_prf 682 eq_refl) (ZtoAQ_pos 682 eq_refl)) +
   ucFun (ARscale (' 96%Z * x))
     (AQarctan_small (AQpi_prf 12943 eq_refl) (ZtoAQ_pos 12943 eq_refl))).

Lemma ARtoCR_preserves_AQpi x : 'AQpi x = r_pi ('x).
Proof.
  unfold AQpi, r_pi.
  assert (∀ (k : Z) (d : positive)
            (Pnd: -(cast Z AQ (Zpos d)) < 1 < cast Z AQ (Zpos d))
            (dpos : 0 < cast Z AQ (Zpos d))
            (Pa : (-1 <= 1#d <= 1)%Q),
             ' ucFun (ARscale ('k * x)) (AQarctan_small Pnd dpos)
             = ucFun (scale (inject_Z k * 'x)) (rational_arctan_small Pa)) as PP.
  { intros.
    rewrite ARtoCR_preserves_scale.
    apply Cmap_wd.
    rewrite rings.preserves_mult, AQtoQ_ZtoAQ.
    reflexivity.
    rewrite AQarctan_small_correct.
    rewrite rational_arctan_small_wd.
    reflexivity.
    rewrite rings.preserves_1.
    pose proof (AQtoQ_ZtoAQ (Zpos d)). rewrite H5.
    reflexivity. }
  assert (forall x y : msp_car AR, ARtoCR (x+y) = 'x + 'y) as plusMorph.
  { intros x0 y. apply (rings.preserves_plus x0 y). }
  unfold cast. unfold cast in plusMorph.
  rewrite plusMorph. apply ucFun2_wd.
  rewrite plusMorph. apply ucFun2_wd.
  apply PP. apply PP.
  rewrite plusMorph.
  apply ucFun2_wd. apply PP. apply PP.
Qed.

Definition ARpi := AQpi 1.

Lemma ARtoCR_preserves_pi : 'ARpi = CRpi.
Proof.
  unfold ARpi, CRpi.
  rewrite ARtoCR_preserves_AQpi.
  rewrite rings.preserves_1.
  reflexivity.
Qed.

End ARpi.


Load "4_more_poly_exercises.v".

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

Arguments Some {X} _.
Arguments None {X}.

Fixpoint beq_nat (n m : nat) : bool :=
  match n with
  | 0 => match m with
         | 0 => true
         | S m' => false
         end
  | S n' => match m with
            | 0 => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint nth_error {X : Type} (l : list X) (n : nat)
                   : option X :=
  match l with
  | [] => None
  | a :: l' => if beq_nat n O then Some a else nth_error l' (pred n)
  end.

Definition hd_error {X : Type} (l : list X) : option X :=
  match l with
  | [] => None
  | (cons x _) => Some x
  end.

Check @hd_error.

Example test_hd_error1 : hd_error [1;2] = Some 1.
Proof.
  simpl. reflexivity.
Qed.

Example test_hd_error2 : hd_error [[1];[2]] = Some [1].
Proof.
  simpl. reflexivity.
Qed.