/-
Copyright (c) 2022 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import ProofChecker.Data.HashMap.Basic
import Std.Data.List.Lemmas
import Std.Data.Array.Lemmas

namespace HashMap
open Std
namespace Imp

attribute [-simp] Bool.not_eq_true

namespace Buckets

@[ext] protected theorem ext : ∀ {b₁ b₂ : Buckets α β}, b₁.1.data = b₂.1.data → b₁ = b₂
  | ⟨⟨_⟩, _⟩, ⟨⟨_⟩, _⟩, rfl => rfl

theorem update_data (self : Buckets α β) (i d h) :
    (self.update i d h).1.data = self.1.data.set i.toNat d := rfl

@[simp] theorem update_size (self : Buckets α β) (i d h) :
    (self.update i d h).1.size = self.1.size := Array.size_uset ..

/-- This theorem, small it may seem, can solve many problems. Apply whenever possible. -/
theorem exists_of_update (self : Buckets α β) (i d h) :
    ∃ l₁ l₂, self.1.data = l₁ ++ self.1[i.toNat] :: l₂ ∧ List.length l₁ = i.toNat ∧
      (self.update i d h).1.data = l₁ ++ d :: l₂ := by
  simp [Array.getElem_eq_data_get]; exact List.exists_of_set' h

theorem size_eq (data : Buckets α β) :
  size data = .sum (data.1.data.map (·.toList.length)) := rfl

theorem mk_size (h) : (mk n h : Buckets α β).size = 0 := by
  simp [Buckets.size_eq, Buckets.mk, mkArray]; clear h
  induction n <;> simp [*]

theorem WF.mk' [BEq α] [Hashable α] (h) : (Buckets.mk n h : Buckets α β).WF := by
  refine ⟨fun _ h => ?_, fun i h => ?_⟩
  · simp [Buckets.mk, empty', mkArray, List.mem_replicate] at h
    simp [h, List.Pairwise.nil]
  · simp [Buckets.mk, empty', mkArray, Array.getElem_eq_data_get, AssocList.All]

theorem WF.update [BEq α] [Hashable α] {buckets : Buckets α β} {i d h} (H : buckets.WF)
    (h₁ : ∀ [PartialEquivBEq α] [LawfulHashable α],
      (buckets.1[i].toList.Pairwise fun a b => ¬(a.1 == b.1)) →
      d.toList.Pairwise fun a b => ¬(a.1 == b.1))
    (h₂ : (buckets.1[i].All fun k _ => ((hash k).toUSize % buckets.1.size).toNat = i.toNat) →
      d.All fun k _ => ((hash k).toUSize % buckets.1.size).toNat = i.toNat) :
    (buckets.update i d h).WF := by
  refine ⟨fun l hl => ?_, fun i hi p hp => ?_⟩
  · exact match List.mem_or_eq_of_mem_set hl with
    | .inl hl => H.1 _ hl
    | .inr rfl => h₁ (H.1 _ (Array.getElem_mem_data ..))
  · revert hp; simp [update_data, Array.getElem_eq_data_get, List.get_set]
    split <;> intro hp
    · next eq => exact eq ▸ h₂ (H.2 _ _) _ hp
    · simp at hi; exact H.2 i hi _ hp

end Buckets

theorem reinsertAux_size [Hashable α] (data : Buckets α β) (a : α) (b : β) :
    (reinsertAux data a b).size = data.size.succ := by
  simp [Buckets.size_eq, reinsertAux]
  refine have ⟨l₁, l₂, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_
  simp [h₁, Nat.succ_add]; rfl

theorem reinsertAux_WF [BEq α] [Hashable α] {data : Buckets α β} {a : α} {b : β} (H : data.WF)
    (h₁ : ∀ [PartialEquivBEq α] [LawfulHashable α],
      haveI := mkIdx (hash a) data.2
      (data.val[this.1]'this.2).All fun x _ => ¬(a == x)) :
    (reinsertAux data a b).WF :=
  H.update (.cons h₁) fun
    | _, _, .head .. => rfl
    | H, _, .tail _ h => H _ h

theorem expand_size [Hashable α] {buckets : Buckets α β} :
    (expand sz buckets).buckets.size = buckets.size := by
  rw [expand, go]
  · rw [Buckets.mk_size]; simp [Buckets.size]
  · intro.
where
  go (i source) (target : Buckets α β) (hs : ∀ j < i, source.data.getD j .nil = .nil) :
      (expand.go i source target).size =
        .sum (source.data.map (·.toList.length)) + target.size := by
    unfold expand.go; split
    · next H =>
      refine (go (i+1) _ _ fun j hj => ?a).trans ?b <;> simp
      · case a =>
        simp [List.getD_eq_get?, List.get?_set]; split
        · cases List.get? .. <;> rfl
        · next H => exact hs _ (Nat.lt_of_le_of_ne (Nat.le_of_lt_succ hj) (Ne.symm H))
      · case b =>
        refine have ⟨l₁, l₂, h₁, _, eq⟩ := List.exists_of_set' H; eq ▸ ?_
        simp [h₁, Buckets.size_eq]
        rw [Nat.add_assoc, Nat.add_assoc, Nat.add_assoc]; congr 1
        (conv => rhs; rw [Nat.add_left_comm]); congr 1
        rw [← Array.getElem_eq_data_get]
        have := @reinsertAux_size α β _; simp [Buckets.size] at this
        induction source[i].toList generalizing target <;> simp [*, Nat.succ_add]; rfl
    · next H =>
      rw [(_ : Nat.sum _ = 0), Nat.zero_add]
      rw [← (_ : source.data.map (fun _ => .nil) = source.data)]
      · simp; induction source.data <;> simp [*]
      refine List.ext_get (by simp) fun j h₁ h₂ => ?_
      simp
      have := (hs j (Nat.lt_of_lt_of_le h₂ (Nat.not_lt.1 H))).symm
      rwa [List.getD_eq_get?, List.get?_eq_get, Option.getD_some] at this
termination_by go i source _ _ => source.size - i

theorem expand_WF.foldl [BEq α] [Hashable α] (rank : α → Nat) {l : List (α × β)} {i : Nat}
    (hl₁ : ∀ [PartialEquivBEq α] [LawfulHashable α], l.Pairwise fun a b => ¬(a.1 == b.1))
    (hl₂ : ∀ x ∈ l, rank x.1 = i)
    {target : Buckets α β} (ht₁ : target.WF)
    (ht₂ : ∀ bucket ∈ target.1.data,
      bucket.All fun k _ => rank k ≤ i ∧
        ∀ [PartialEquivBEq α] [LawfulHashable α], ∀ x ∈ l, ¬(x.1 == k)) :
    (l.foldl (fun d x => reinsertAux d x.1 x.2) target).WF ∧
    ∀ bucket ∈ (l.foldl (fun d x => reinsertAux d x.1 x.2) target).1.data,
      bucket.All fun k _ => rank k ≤ i := by
  induction l generalizing target with
  | nil => exact ⟨ht₁, fun _ h₁ _ h₂ => (ht₂ _ h₁ _ h₂).1⟩
  | cons _ _ ih =>
    simp at hl₁ hl₂ ht₂
    refine ih hl₁.2 hl₂.2
      (reinsertAux_WF ht₁ fun _ h => (ht₂ _ (Array.getElem_mem_data ..) _ h).2.1)
      (fun _ h => ?_)
    simp [reinsertAux, Buckets.update] at h
    match List.mem_or_eq_of_mem_set h with
    | .inl h =>
      intro _ hf
      have ⟨h₁, h₂⟩ := ht₂ _ h _ hf
      exact ⟨h₁, h₂.2⟩
    | .inr h => subst h; intro
      | _, .head .. =>
        exact ⟨hl₂.1 ▸ Nat.le_refl _, fun _ h h' => hl₁.1 _ h (PartialEquivBEq.symm h')⟩
      | _, .tail _ h =>
        have ⟨h₁, h₂⟩ := ht₂ _ (Array.getElem_mem_data ..) _ h
        exact ⟨h₁, h₂.2⟩

theorem expand_WF [BEq α] [Hashable α] {buckets : Buckets α β} (H : buckets.WF) :
    (expand sz buckets).buckets.WF :=
  go _ H.1 H.2 ⟨.mk' _, fun _ _ _ _ => by simp_all [Buckets.mk, List.mem_replicate]⟩
where
  go (i) {source : Array (AssocList α β)}
      (hs₁ : ∀ [LawfulHashable α] [PartialEquivBEq α], ∀ bucket ∈ source.data,
        bucket.toList.Pairwise fun a b => ¬(a.1 == b.1))
      (hs₂ : ∀ (j : Nat) (h : j < source.size),
        source[j].All fun k _ => ((hash k).toUSize % source.size).toNat = j)
      {target : Buckets α β} (ht : target.WF ∧ ∀ bucket ∈ target.1.data,
        bucket.All fun k _ => ((hash k).toUSize % source.size).toNat < i) :
      (expand.go i source target).WF := by
    unfold expand.go; split
    · next H =>
      refine go (i+1) (fun _ hl => ?_) (fun i h => ?_) ?_
      · match List.mem_or_eq_of_mem_set hl with
        | .inl hl => exact hs₁ _ hl
        | .inr e => exact e ▸ .nil
      · simp [Array.getElem_eq_data_get, List.get_set]; split
        · intro.
        · exact hs₂ _ (by simp_all)
      · let rank (k : α) := ((hash k).toUSize % source.size).toNat
        have := expand_WF.foldl rank ?_ (hs₂ _ H) ht.1 (fun _ h₁ _ h₂ => ?_)
        · simp; exact ⟨this.1, fun _ h₁ _ h₂ => Nat.lt_succ_of_le (this.2 _ h₁ _ h₂)⟩
        · exact hs₁ _ (Array.getElem_mem_data ..)
        · have := ht.2 _ h₁ _ h₂
          refine ⟨Nat.le_of_lt this, fun _ h h' => Nat.ne_of_lt this ?_⟩
          exact LawfulHashable.hash_eq h' ▸ hs₂ _ H _ h
    · exact ht.1
termination_by go i source _ _ _ _ => source.size - i

theorem insert_size [BEq α] [Hashable α] {m : Imp α β} {k v}
    (h : m.size = m.buckets.size) :
    (insert m k v).size = (insert m k v).buckets.size := by
  dsimp [insert, cond]; split
  · unfold Buckets.size
    refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_
    simp [h, h₁, Buckets.size_eq]
  split
  · unfold Buckets.size
    refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_
    simp [h, h₁, Buckets.size_eq, Nat.succ_add]; rfl
  · rw [expand_size]; simp [h, expand, Buckets.size]
    refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_
    simp [h₁, Buckets.size_eq, Nat.succ_add]; rfl

private theorem mem_replaceF {l : List (α × β)} {x : α × β} {p : α × β → Bool} :
    x ∈ (l.replaceF fun a => bif p a then some (k, v) else none) → x.1 = k ∨ x ∈ l := by
  induction l with
  | nil => exact .inr
  | cons a l ih =>
    simp; generalize e : cond .. = z; revert e
    unfold cond; split <;> (intro h; subst h; simp)
    · intro
      | .inl eq => exact eq ▸ .inl rfl
      | .inr h => exact .inr (.inr h)
    · intro
      | .inl eq => exact .inr (.inl eq)
      | .inr h => exact (ih h).imp_right .inr

private theorem pairwise_replaceF [BEq α] [PartialEquivBEq α]
    {l : List (α × β)} {x : α × β} (hx₁ : x ∈ l) (hx₂ : x.fst == k)
    (H : l.Pairwise fun a b => ¬(a.fst == b.fst)) :
    (l.replaceF fun a => bif a.fst == k then some (k, v) else none)
      |>.Pairwise fun a b => ¬(a.fst == b.fst) := by
  induction hx₁ with
  | head => simp_all; exact (H.1 · · ∘ PartialEquivBEq.trans hx₂)
  | tail _ _ ih =>
    simp at H ⊢
    generalize e : cond .. = z; revert e
    unfold cond; split <;> (intro h; subst h; simp)
    · next e => exact ⟨(H.1 · · ∘ PartialEquivBEq.trans e), H.2⟩
    · next e =>
      refine ⟨fun a h => ?_, ih H.2⟩
      match mem_replaceF h with
      | .inl eq => exact eq ▸ ne_true_of_eq_false e
      | .inr h => exact H.1 a h

theorem insert_WF [BEq α] [Hashable α] {m : Imp α β} {k v}
    (h : m.buckets.WF) : (insert m k v).buckets.WF := by
  dsimp [insert, cond]; split
  · next h₁ =>
    simp at h₁; have ⟨x, hx₁, hx₂⟩ := h₁
    refine h.update (fun H => ?_) (fun H a h => ?_)
    · simp; exact pairwise_replaceF hx₁ hx₂ H
    · simp [AssocList.All] at H h ⊢
      match mem_replaceF h with
      | .inl rfl => rfl
      | .inr h => exact H _ h
  · next h₁ =>
    rw [Bool.eq_false_iff] at h₁; simp at h₁
    suffices _ by split <;> [exact this, refine expand_WF this]
    refine h.update (.cons ?_) (fun H a h => ?_)
    · exact fun a h h' => h₁ a h (PartialEquivBEq.symm h')
    · cases h with
      | head => rfl
      | tail _ h => exact H _ h

theorem erase_size [BEq α] [Hashable α] {m : Imp α β} {k}
    (h : m.size = m.buckets.size) :
    (erase m k).size = (erase m k).buckets.size := by
  dsimp [erase, cond]; split
  · next H =>
    simp [h, Buckets.size]
    refine have ⟨_, _, h₁, _, eq⟩ := Buckets.exists_of_update ..; eq ▸ ?_
    simp [h, h₁, Buckets.size_eq]
    rw [(_ : List.length _ = _ + 1), Nat.add_right_comm]; {rfl}
    clear h₁ eq
    simp [AssocList.contains_eq] at H
    have ⟨a, h₁, h₂⟩ := H
    refine have ⟨_, _, _, _, _, h, eq⟩ := List.exists_of_eraseP h₁ h₂; eq ▸ ?_
    simp [h]; rfl
  · exact h

theorem erase_WF [BEq α] [Hashable α] {m : Imp α β} {k}
    (h : m.buckets.WF) : (erase m k).buckets.WF := by
  dsimp [erase, cond]; split
  · refine h.update (fun H => ?_) (fun H a h => ?_) <;> simp at h ⊢
    · simp; exact H.sublist (List.eraseP_sublist _)
    · exact H _ (List.mem_of_mem_eraseP h)
  · exact h

theorem WF.out [BEq α] [Hashable α] {m : Imp α β} (h : m.WF) :
    m.size = m.buckets.size ∧ m.buckets.WF := by
  induction h with
  | mk h₁ h₂ => exact ⟨h₁, h₂⟩
  | @empty' _ h => exact ⟨(Buckets.mk_size h).symm, .mk' h⟩
  | insert _ ih => exact ⟨insert_size ih.1, insert_WF ih.2⟩
  | erase _ ih => exact ⟨erase_size ih.1, erase_WF ih.2⟩

theorem WF_iff [BEq α] [Hashable α] {m : Imp α β} :
    m.WF ↔ m.size = m.buckets.size ∧ m.buckets.WF :=
  ⟨(·.out), fun ⟨h₁, h₂⟩ => .mk h₁ h₂⟩

theorem WF.mapVal {α β γ} {f : α → β → γ} [BEq α] [Hashable α]
    {m : Imp α β} (H : WF m) : WF (mapVal f m) := by
  have ⟨h₁, h₂⟩ := H.out
  simp [Imp.mapVal, Buckets.mapVal, WF_iff, h₁]; refine ⟨?_, ?_, fun i h => ?_⟩
  · simp [Buckets.size]; congr; funext l; simp
  · simp [List.forall_mem_map_iff, List.pairwise_map]
    exact fun _ => h₂.distinct _
  · simp [AssocList.All, List.forall_mem_map_iff] at h ⊢
    exact h₂.2 _ h

theorem WF.filterMap {α β γ} {f : α → β → Option γ} [BEq α] [Hashable α]
    {m : Imp α β} (H : WF m) : WF (filterMap f m) := by
  let g₁ (l : AssocList α β) := l.toList.filterMap (fun x => (f x.1 x.2).map (x.1, ·))
  have H1 (l n acc) : filterMap.go f acc l n =
      (((g₁ l).reverse ++ acc.toList).toAssocList, ⟨n.1 + (g₁ l).length⟩) := by
    induction l generalizing n acc with simp [filterMap.go, *]
    | cons a b l => match f a b with
      | none => rfl
      | some c => simp; rw [Nat.add_right_comm]; rfl
  let g l := (g₁ l).reverse.toAssocList
  let M := StateT (ULift Nat) Id
  have H2 (l : List (AssocList α β)) n :
      l.mapM (m := M) (filterMap.go f .nil) n =
      (l.map g, ⟨n.1 + .sum ((l.map g).map (·.toList.length))⟩) := by
    induction l generalizing n with
    | nil => rfl
    | cons l L IH => simp [bind, StateT.bind, IH, H1, Nat.add_assoc]; rfl
  have H3 (l : List _) :
    (l.filterMap (fun (a, b) => (f a b).map (a, ·))).map (fun a => a.fst)
     |>.Sublist (l.map (·.1)) := by
    induction l with
    | nil => exact .slnil
    | cons a l ih =>
      simp; exact match f a.1 a.2 with
      | none => .cons _ ih
      | some b => .cons₂ _ ih
  suffices ∀ bk sz (h : bk.length.isPowerOfTwo),
    m.buckets.val.mapM (m := M) (filterMap.go f .nil) ⟨0⟩ = (⟨bk⟩, ⟨sz⟩) →
    WF ⟨sz, ⟨bk⟩, h⟩ from this _ _ _ rfl
  simp [Array.mapM_eq_mapM_data, bind, StateT.bind, H2]
  intro bk sz h e'; cases e'
  refine .mk (by simp [Buckets.size]) ⟨?_, fun i h => ?_⟩
  · simp [List.forall_mem_map_iff]
    refine fun l h => (List.pairwise_reverse.2 ?_).imp (mt PartialEquivBEq.symm)
    have := H.out.2.1 _ h
    rw [← List.pairwise_map (R := (¬ · == ·))] at this ⊢
    exact this.sublist (H3 l.toList)
  · simp [Array.getElem_eq_data_get] at h ⊢
    have := H.out.2.2 _ h
    simp [AssocList.All] at this ⊢
    rw [← List.forall_mem_map_iff
      (P := fun a => ((hash a).toUSize % m.buckets.val.data.length).toNat = i)] at this ⊢
    exact fun _ h' => this _ ((H3 _).subset h')

end Imp

variable {_ : BEq α} {_ : Hashable α}

/-- Map a function over the values in the map. -/
@[inline] def mapVal (f : α → β → γ) (self : HashMap α β) : HashMap α γ :=
  ⟨self.1.mapVal f, self.2.mapVal⟩

/--
Applies `f` to each key-value pair `a, b` in the map. If it returns `some c` then
`a, c` is pushed into the new map; else the key is removed from the map.
-/
@[inline] def filterMap (f : α → β → Option γ) (self : HashMap α β) : HashMap α γ :=
  ⟨self.1.filterMap f, self.2.filterMap⟩

/-- Constructs a map with the set of all pairs `a, b` such that `f` returns true. -/
@[inline] def filter (f : α → β → Bool) (self : HashMap α β) : HashMap α β :=
  self.filterMap fun a b => bif f a b then some b else none


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.group.arithmetic

/-!
# (Scalar) multiplication and (vector) addition as measurable equivalences

In this file we define the following measurable equivalences:

* `measurable_equiv.smul`: if a group `G` acts on `α` by measurable maps, then each element `c : G`
  defines a measurable automorphism of `α`;
* `measurable_equiv.vadd`: additive version of `measurable_equiv.smul`;
* `measurable_equiv.smul₀`: if a group with zero `G` acts on `α` by measurable maps, then each
  nonzero element `c : G` defines a measurable automorphism of `α`;
* `measurable_equiv.mul_left`: if `G` is a group with measurable multiplication, then left
  multiplication by `g : G` is a measurable automorphism of `G`;
* `measurable_equiv.add_left`: additive version of `measurable_equiv.mul_left`;
* `measurable_equiv.mul_right`: if `G` is a group with measurable multiplication, then right
  multiplication by `g : G` is a measurable automorphism of `G`;
* `measurable_equiv.add_right`: additive version of `measurable_equiv.mul_right`;
* `measurable_equiv.mul_left₀`, `measurable_equiv.mul_right₀`: versions of
  `measurable_equiv.mul_left` and `measurable_equiv.mul_right` for groups with zero;
* `measurable_equiv.inv`: `has_inv.inv` as a measurable automorphism
  of a group (or a group with zero);
* `measurable_equiv.neg`: negation as a measurable automorphism of an additive group.

We also deduce that the corresponding maps are measurable embeddings.

## Tags

measurable, equivalence, group action
-/

namespace measurable_equiv

variables {G G₀ α : Type*} [measurable_space G] [measurable_space G₀] [measurable_space α]
  [group G] [group_with_zero G₀] [mul_action G α] [mul_action G₀ α]
  [has_measurable_smul G α] [has_measurable_smul G₀ α]

/-- If a group `G` acts on `α` by measurable maps, then each element `c : G` defines a measurable
automorphism of `α`. -/
@[to_additive "If an additive group `G` acts on `α` by measurable maps, then each element `c : G`
defines a measurable automorphism of `α`.", simps to_equiv apply { fully_applied := ff }]
def smul (c : G) : α ≃ᵐ α :=
{ to_equiv := mul_action.to_perm c,
  measurable_to_fun := measurable_const_smul c,
  measurable_inv_fun := measurable_const_smul c⁻¹ }

@[to_additive]
lemma _root_.measurable_embedding_const_smul (c : G) : measurable_embedding ((•) c : α → α) :=
(smul c).measurable_embedding

@[simp, to_additive]

/-- If a group with zero `G₀` acts on `α` by measurable maps, then each nonzero element `c : G₀`
defines a measurable automorphism of `α` -/
def smul₀ (c : G₀) (hc : c ≠ 0) : α ≃ᵐ α :=
measurable_equiv.smul (units.mk0 c hc)

@[simp] lemma coe_smul₀ {c : G₀} (hc : c ≠ 0) : ⇑(smul₀ c hc : α ≃ᵐ α) = (•) c := rfl

@[simp] lemma symm_smul₀ {c : G₀} (hc : c ≠ 0) :
  (smul₀ c hc : α ≃ᵐ α).symm = smul₀ c⁻¹ (inv_ne_zero hc) :=
ext rfl

lemma _root_.measurable_embedding_const_smul₀ {c : G₀} (hc : c ≠ 0) :
  measurable_embedding ((•) c : α → α) :=
(smul₀ c hc).measurable_embedding

section mul

variables [has_measurable_mul G] [has_measurable_mul G₀]

/-- If `G` is a group with measurable multiplication, then left multiplication by `g : G` is a
measurable automorphism of `G`. -/
@[to_additive "If `G` is an additive group with measurable addition, then addition of `g : G`
on the left is a measurable automorphism of `G`."]
def mul_left (g : G) : G ≃ᵐ G := smul g

@[simp, to_additive] lemma coe_mul_left (g : G) : ⇑(mul_left g) = (*) g := rfl

@[simp, to_additive] lemma symm_mul_left (g : G) : (mul_left g).symm = mul_left g⁻¹ := ext rfl

@[simp, to_additive] lemma to_equiv_mul_left (g : G) :
  (mul_left g).to_equiv = equiv.mul_left g := rfl

@[to_additive]
lemma _root_.measurable_embedding_mul_left (g : G) : measurable_embedding ((*) g) :=
(mul_left g).measurable_embedding

/-- If `G` is a group with measurable multiplication, then right multiplication by `g : G` is a
measurable automorphism of `G`. -/
@[to_additive "If `G` is an additive group with measurable addition, then addition of `g : G`
on the right is a measurable automorphism of `G`."]
def mul_right (g : G) : G ≃ᵐ G :=
{ to_equiv := equiv.mul_right g,
  measurable_to_fun := measurable_mul_const g,
  measurable_inv_fun := measurable_mul_const g⁻¹ }

@[to_additive]
lemma _root_.measurable_embedding_mul_right (g : G) : measurable_embedding (λ x, x * g) :=
(mul_right g).measurable_embedding

@[simp, to_additive] lemma coe_mul_right (g : G) : ⇑(mul_right g) = (λ x, x * g) := rfl

@[simp, to_additive] lemma symm_mul_right (g : G) : (mul_right g).symm = mul_right g⁻¹ := ext rfl

@[simp, to_additive] lemma to_equiv_mul_right (g : G) :
  (mul_right g).to_equiv = equiv.mul_right g := rfl

/-- If `G₀` is a group with zero with measurable multiplication, then left multiplication by a
nonzero element `g : G₀` is a measurable automorphism of `G₀`. -/
def mul_left₀ (g : G₀) (hg : g ≠ 0) : G₀ ≃ᵐ G₀ := smul₀ g hg

lemma _root_.measurable_embedding_mul_left₀ {g : G₀} (hg : g ≠ 0) : measurable_embedding ((*) g) :=
(mul_left₀ g hg).measurable_embedding

@[simp] lemma coe_mul_left₀ {g : G₀} (hg : g ≠ 0) : ⇑(mul_left₀ g hg) = (*) g := rfl

@[simp] lemma symm_mul_left₀ {g : G₀} (hg : g ≠ 0) :
  (mul_left₀ g hg).symm = mul_left₀ g⁻¹ (inv_ne_zero hg)  := ext rfl

@[simp] lemma to_equiv_mul_left₀ {g : G₀} (hg : g ≠ 0) :
  (mul_left₀ g hg).to_equiv = equiv.mul_left₀ g hg := rfl

/-- If `G₀` is a group with zero with measurable multiplication, then right multiplication by a
nonzero element `g : G₀` is a measurable automorphism of `G₀`. -/
def mul_right₀ (g : G₀) (hg : g ≠ 0) : G₀ ≃ᵐ G₀ :=
{ to_equiv := equiv.mul_right₀ g hg,
  measurable_to_fun := measurable_mul_const g,
  measurable_inv_fun := measurable_mul_const g⁻¹ }

lemma _root_.measurable_embedding_mul_right₀ {g : G₀} (hg : g ≠ 0) :
  measurable_embedding (λ x, x * g) :=
(mul_right₀ g hg).measurable_embedding

@[simp] lemma coe_mul_right₀ {g : G₀} (hg : g ≠ 0) : ⇑(mul_right₀ g hg) = λ x, x * g := rfl

@[simp] lemma symm_mul_right₀ {g : G₀} (hg : g ≠ 0) :
  (mul_right₀ g hg).symm = mul_right₀ g⁻¹ (inv_ne_zero hg)  := ext rfl

@[simp] lemma to_equiv_mul_right₀ {g : G₀} (hg : g ≠ 0) :
  (mul_right₀ g hg).to_equiv = equiv.mul_right₀ g hg := rfl

end mul

/-- Inversion as a measurable automorphism of a group or group with zero. -/
@[to_additive "Negation as a measurable automorphism of an additive group.",
  simps to_equiv apply { fully_applied := ff }]
def inv (G) [measurable_space G] [has_involutive_inv G] [has_measurable_inv G] : G ≃ᵐ G :=
{ to_equiv := equiv.inv G,
  measurable_to_fun := measurable_inv,
  measurable_inv_fun := measurable_inv }

@[simp, to_additive]
lemma symm_inv {G} [measurable_space G] [has_involutive_inv G] [has_measurable_inv G] :
  (inv G).symm = inv G := rfl

/-- `equiv.div_right` as a `measurable_equiv`. -/
@[to_additive /-" `equiv.sub_right` as a `measurable_equiv` "-/]
def div_right [has_measurable_mul G] (g : G) : G ≃ᵐ G :=
{ to_equiv := equiv.div_right g,
  measurable_to_fun := measurable_div_const' g,
  measurable_inv_fun := measurable_mul_const g }

/-- `equiv.div_left` as a `measurable_equiv` -/
@[to_additive /-" `equiv.sub_left` as a `measurable_equiv` "-/]
def div_left [has_measurable_mul G] [has_measurable_inv G] (g : G) : G ≃ᵐ G :=
{ to_equiv := equiv.div_left g,
  measurable_to_fun := measurable_id.const_div g,
  measurable_inv_fun := measurable_inv.mul_const g }

end measurable_equiv


/-
Copyright (c) 2022 Yuma Mizuno. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yuma Mizuno
-/
import category_theory.bicategory.basic

/-!
# Oplax functors and pseudofunctors

An oplax functor `F` between bicategories `B` and `C` consists of
* a function between objects `F.obj : B ⟶ C`,
* a family of functions between 1-morphisms `F.map : (a ⟶ b) → (F.obj a ⟶ F.obj b)`,
* a family of functions between 2-morphisms `F.map₂ : (f ⟶ g) → (F.map f ⟶ F.map g)`,
* a family of 2-morphisms `F.map_id a : F.map (𝟙 a) ⟶ 𝟙 (F.obj a)`,
* a family of 2-morphisms `F.map_comp f g : F.map (f ≫ g) ⟶ F.map f ≫ F.map g`, and
* certain consistency conditions on them.

A pseudofunctor is an oplax functor whose `map_id` and `map_comp` are isomorphisms. We provide
several constructors for pseudofunctors:
* `pseudofunctor.mk` : the default constructor, which requires `map₂_whisker_left` and
  `map₂_whisker_right` instead of naturality of `map_comp`.
* `pseudofunctor.mk_of_oplax` : construct a pseudofunctor from an oplax functor whose
  `map_id` and `map_comp` are isomorphisms. This constructor uses `iso` to describe isomorphisms.
* `pseudofunctor.mk_of_oplax'` : similar to `mk_of_oplax`, but uses `is_iso` to describe
  isomorphisms.

The additional constructors are useful when constructing a pseudofunctor where the construction
of the oplax functor associated with it is already done. For example, the composition of
pseudofunctors can be defined by using the composition of oplax functors as follows:
```lean
def pseudofunctor.comp (F : pseudofunctor B C) (G : pseudofunctor C D) : pseudofunctor B D :=
mk_of_oplax ((F : oplax_functor B C).comp G)
{ map_id_iso := λ a, (G.map_functor _ _).map_iso (F.map_id a) ≪≫ G.map_id (F.obj a),
  map_comp_iso := λ a b c f g,
    (G.map_functor _ _).map_iso (F.map_comp f g) ≪≫ G.map_comp (F.map f) (F.map g) }
```
although the composition of pseudofunctors in this file is defined by using the default constructor
because `obviously` is smart enough. Similarly, the composition is also defined by using
`mk_of_oplax'` after giving appropriate instances for `is_iso`. The former constructor
`mk_of_oplax` requires isomorphisms as data type `iso`, and so it is useful if you don't want
to forget the definitions of the inverses. On the other hand, the latter constructor
`mk_of_oplax'` is useful if you want to use propositional type class `is_iso`.

## Main definitions

* `category_theory.oplax_functor B C` : an oplax functor between bicategories `B` and `C`
* `category_theory.oplax_functor.comp F G` : the composition of oplax functors
* `category_theory.pseudofunctor B C` : a pseudofunctor between bicategories `B` and `C`
* `category_theory.pseudofunctor.comp F G` : the composition of pseudofunctors

## Future work

There are two types of functors between bicategories, called lax and oplax functors, depending on
the directions of `map_id` and `map_comp`. We may need both in mathlib in the future, but for
now we only define oplax functors.
-/

set_option old_structure_cmd true

namespace category_theory

open category bicategory
open_locale bicategory

universes w₁ w₂ w₃ v₁ v₂ v₃ u₁ u₂ u₃

section
variables {B : Type u₁} [quiver.{v₁+1} B] [∀ a b : B, quiver.{w₁+1} (a ⟶ b)]
variables {C : Type u₂} [quiver.{v₂+1} C] [∀ a b : C, quiver.{w₂+1} (a ⟶ b)]
variables {D : Type u₃} [quiver.{v₃+1} D] [∀ a b : D, quiver.{w₃+1} (a ⟶ b)]

/--
A prelax functor between bicategories consists of functions between objects,
1-morphisms, and 2-morphisms. This structure will be extended to define `oplax_functor`.
-/
structure prelax_functor
  (B : Type u₁) [quiver.{v₁+1} B] [∀ a b : B, quiver.{w₁+1} (a ⟶ b)]
  (C : Type u₂) [quiver.{v₂+1} C] [∀ a b : C, quiver.{w₂+1} (a ⟶ b)] extends prefunctor B C :=
(map₂ {a b : B} {f g : a ⟶ b} : (f ⟶ g) → (map f ⟶ map g))

/-- The prefunctor between the underlying quivers. -/
add_decl_doc prelax_functor.to_prefunctor

namespace prelax_functor

instance has_coe_to_prefunctor : has_coe (prelax_functor B C) (prefunctor B C) := ⟨to_prefunctor⟩

variables (F : prelax_functor B C)

@[simp] lemma to_prefunctor_eq_coe : F.to_prefunctor = F := rfl
@[simp] lemma to_prefunctor_obj : (F : prefunctor B C).obj = F.obj := rfl
@[simp] lemma to_prefunctor_map : (F : prefunctor B C).map = F.map := rfl

/-- The identity prelax functor. -/
@[simps]
def id (B : Type u₁) [quiver.{v₁+1} B] [∀ a b : B, quiver.{w₁+1} (a ⟶ b)] : prelax_functor B B :=
{ map₂ := λ a b f g η, η, .. prefunctor.id B }

instance : inhabited (prelax_functor B B) := ⟨prelax_functor.id B⟩

/-- Composition of prelax functors. -/
@[simps]
def comp (F : prelax_functor B C) (G : prelax_functor C D) : prelax_functor B D :=
{ map₂ := λ a b f g η, G.map₂ (F.map₂ η), .. (F : prefunctor B C).comp ↑G }

end prelax_functor

end

section
variables {B : Type u₁} [bicategory.{w₁ v₁} B] {C : Type u₂} [bicategory.{w₂ v₂} C]
variables {D : Type u₃} [bicategory.{w₃ v₃} D]

/--
This auxiliary definition states that oplax functors preserve the associators
modulo some adjustments of domains and codomains of 2-morphisms.
-/
/-
We use this auxiliary definition instead of writing it directly in the definition
of oplax functors because doing so will cause a timeout.
-/
@[simp]
def oplax_functor.map₂_associator_aux
  (obj : B → C) (map : Π {X Y : B}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (map₂ : Π {a b : B} {f g : a ⟶ b}, (f ⟶ g) → (map f ⟶ map g))
  (map_comp : Π {a b c : B} (f : a ⟶ b) (g : b ⟶ c), map (f ≫ g) ⟶ map f ≫ map g)
  {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) : Prop :=
map₂ (α_ f g h).hom ≫ map_comp f (g ≫ h) ≫ map f ◁ map_comp g h =
  map_comp (f ≫ g) h ≫ map_comp f g ▷ map h ≫ (α_ (map f) (map g) (map h)).hom

/--
An oplax functor `F` between bicategories `B` and `C` consists of a function between objects
`F.obj`, a function between 1-morphisms `F.map`, and a function between 2-morphisms `F.map₂`.

Unlike functors between categories, `F.map` do not need to strictly commute with the composition,
and do not need to strictly preserve the identity. Instead, there are specified 2-morphisms
`F.map (𝟙 a) ⟶ 𝟙 (F.obj a)` and `F.map (f ≫ g) ⟶ F.map f ≫ F.map g`.

`F.map₂` strictly commute with compositions and preserve the identity. They also preserve the
associator, the left unitor, and the right unitor modulo some adjustments of domains and codomains
of 2-morphisms.
-/
structure oplax_functor (B : Type u₁) [bicategory.{w₁ v₁} B] (C : Type u₂) [bicategory.{w₂ v₂} C]
  extends prelax_functor B C :=
(map_id (a : B) : map (𝟙 a) ⟶ 𝟙 (obj a))
(map_comp {a b c : B} (f : a ⟶ b) (g : b ⟶ c) : map (f ≫ g) ⟶ map f ≫ map g)
(map_comp_naturality_left' : ∀ {a b c : B} {f f' : a ⟶ b} (η : f ⟶ f') (g : b ⟶ c),
  map₂ (η ▷ g) ≫ map_comp f' g = map_comp f g ≫ map₂ η ▷ map g . obviously)
(map_comp_naturality_right' : ∀ {a b c : B} (f : a ⟶ b) {g g' : b ⟶ c} (η : g ⟶ g'),
  map₂ (f ◁ η) ≫ map_comp f g' = map_comp f g ≫ map f ◁ map₂ η . obviously)
(map₂_id' : ∀ {a b : B} (f : a ⟶ b), map₂ (𝟙 f) = 𝟙 (map f) . obviously)
(map₂_comp' : ∀ {a b : B} {f g h : a ⟶ b} (η : f ⟶ g) (θ : g ⟶ h),
  map₂ (η ≫ θ) = map₂ η ≫ map₂ θ . obviously)
(map₂_associator' : ∀ {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d),
  oplax_functor.map₂_associator_aux obj (λ a b, map) (λ a b f g, map₂) (λ a b c, map_comp) f g h
    . obviously)
(map₂_left_unitor' : ∀ {a b : B} (f : a ⟶ b),
  map₂ (λ_ f).hom = map_comp (𝟙 a) f ≫ map_id a ▷ map f ≫ (λ_ (map f)).hom . obviously)
(map₂_right_unitor' : ∀ {a b : B} (f : a ⟶ b),
  map₂ (ρ_ f).hom = map_comp f (𝟙 b) ≫ map f ◁ map_id b ≫ (ρ_ (map f)).hom . obviously)

namespace oplax_functor

restate_axiom map_comp_naturality_left'
restate_axiom map_comp_naturality_right'
restate_axiom map₂_id'
restate_axiom map₂_comp'
restate_axiom map₂_associator'
restate_axiom map₂_left_unitor'
restate_axiom map₂_right_unitor'
attribute [simp] map_comp_naturality_left map_comp_naturality_right map₂_id map₂_associator
attribute [reassoc]
  map_comp_naturality_left map_comp_naturality_right map₂_comp
  map₂_associator map₂_left_unitor map₂_right_unitor
attribute [simp] map₂_comp map₂_left_unitor map₂_right_unitor

section

/-- The prelax functor between the underlying quivers. -/
add_decl_doc oplax_functor.to_prelax_functor

instance has_coe_to_prelax : has_coe (oplax_functor B C) (prelax_functor B C) :=
⟨to_prelax_functor⟩

variables (F : oplax_functor B C)

@[simp] lemma to_prelax_eq_coe : F.to_prelax_functor = F := rfl
@[simp] lemma to_prelax_functor_obj : (F : prelax_functor B C).obj = F.obj := rfl
@[simp] lemma to_prelax_functor_map : (F : prelax_functor B C).map = F.map := rfl
@[simp] lemma to_prelax_functor_map₂ : (F : prelax_functor B C).map₂ = F.map₂ := rfl

/-- Function between 1-morphisms as a functor. -/
@[simps]
def map_functor (a b : B) : (a ⟶ b) ⥤ (F.obj a ⟶ F.obj b) :=
{ obj := λ f, F.map f,
  map := λ f g η, F.map₂ η }

/-- The identity oplax functor. -/
@[simps]
def id (B : Type u₁) [bicategory.{w₁ v₁} B] : oplax_functor B B :=
{ map_id := λ a, 𝟙 (𝟙 a),
  map_comp := λ a b c f g, 𝟙 (f ≫ g),
  .. prelax_functor.id B }

instance : inhabited (oplax_functor B B) := ⟨id B⟩

/-- Composition of oplax functors. -/
@[simps]
def comp (F : oplax_functor B C) (G : oplax_functor C D) : oplax_functor B D :=
{ map_id := λ a,
    (G.map_functor _ _).map (F.map_id a) ≫ G.map_id (F.obj a),
  map_comp := λ a b c f g,
    (G.map_functor _ _).map (F.map_comp f g) ≫ G.map_comp (F.map f) (F.map g),
  map_comp_naturality_left' := λ a b c f f' η g, by
  { dsimp,
    rw [←map₂_comp_assoc, map_comp_naturality_left, map₂_comp_assoc, map_comp_naturality_left,
      assoc] },
  map_comp_naturality_right' := λ a b c f g g' η, by
  { dsimp,
    rw [←map₂_comp_assoc, map_comp_naturality_right, map₂_comp_assoc, map_comp_naturality_right,
      assoc] },
  map₂_associator' := λ a b c d f g h, by
  { dsimp,
    simp only [map₂_associator, ←map₂_comp_assoc, ←map_comp_naturality_right_assoc,
      whisker_left_comp, assoc],
    simp only [map₂_associator, map₂_comp, map_comp_naturality_left_assoc,
      comp_whisker_right, assoc] },
  map₂_left_unitor' := λ a b f, by
  { dsimp,
    simp only [map₂_left_unitor, map₂_comp, map_comp_naturality_left_assoc,
      comp_whisker_right, assoc] },
  map₂_right_unitor' := λ a b f, by
  { dsimp,
    simp only [map₂_right_unitor, map₂_comp, map_comp_naturality_right_assoc,
      whisker_left_comp, assoc] },
  .. (F : prelax_functor B C).comp ↑G }

/--
A structure on an oplax functor that promotes an oplax functor to a pseudofunctor.
See `pseudofunctor.mk_of_oplax`.
-/
@[nolint has_inhabited_instance]
structure pseudo_core (F : oplax_functor B C) :=
(map_id_iso (a : B) : F.map (𝟙 a) ≅ 𝟙 (F.obj a))
(map_comp_iso {a b c : B} (f : a ⟶ b) (g : b ⟶ c) : F.map (f ≫ g) ≅ F.map f ≫ F.map g)
(map_id_iso_hom' : ∀ {a : B}, (map_id_iso a).hom = F.map_id a . obviously)
(map_comp_iso_hom' : ∀ {a b c : B} (f : a ⟶ b) (g : b ⟶ c),
  (map_comp_iso f g).hom = F.map_comp f g . obviously)

restate_axiom pseudo_core.map_id_iso_hom'
restate_axiom pseudo_core.map_comp_iso_hom'
attribute [simp] pseudo_core.map_id_iso_hom pseudo_core.map_comp_iso_hom

end

end oplax_functor

/--
This auxiliary definition states that pseudofunctors preserve the associators
modulo some adjustments of domains and codomains of 2-morphisms.
-/
/-
We use this auxiliary definition instead of writing it directly in the definition
of pseudofunctors because doing so will cause a timeout.
-/
@[simp]
def pseudofunctor.map₂_associator_aux
  (obj : B → C) (map : Π {X Y : B}, (X ⟶ Y) → (obj X ⟶ obj Y))
  (map₂ : Π {a b : B} {f g : a ⟶ b}, (f ⟶ g) → (map f ⟶ map g))
  (map_comp : Π {a b c : B} (f : a ⟶ b) (g : b ⟶ c), map (f ≫ g) ≅ map f ≫ map g)
  {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d) : Prop :=
map₂ (α_ f g h).hom = (map_comp (f ≫ g) h).hom ≫ (map_comp f g).hom ▷ map h ≫
  (α_ (map f) (map g) (map h)).hom ≫ map f ◁ (map_comp g h).inv ≫ (map_comp f (g ≫ h)).inv

/--
A pseudofunctor `F` between bicategories `B` and `C` consists of a function between objects
`F.obj`, a function between 1-morphisms `F.map`, and a function between 2-morphisms `F.map₂`.

Unlike functors between categories, `F.map` do not need to strictly commute with the compositions,
and do not need to strictly preserve the identity. Instead, there are specified 2-isomorphisms
`F.map (𝟙 a) ≅ 𝟙 (F.obj a)` and `F.map (f ≫ g) ≅ F.map f ≫ F.map g`.

`F.map₂` strictly commute with compositions and preserve the identity. They also preserve the
associator, the left unitor, and the right unitor modulo some adjustments of domains and codomains
of 2-morphisms.
-/
structure pseudofunctor (B : Type u₁) [bicategory.{w₁ v₁} B] (C : Type u₂) [bicategory.{w₂ v₂} C]
  extends prelax_functor B C :=
(map_id (a : B) : map (𝟙 a) ≅ 𝟙 (obj a))
(map_comp {a b c : B} (f : a ⟶ b) (g : b ⟶ c) : map (f ≫ g) ≅ map f ≫ map g)
(map₂_id' : ∀ {a b : B} (f : a ⟶ b), map₂ (𝟙 f) = 𝟙 (map f) . obviously)
(map₂_comp' : ∀ {a b : B} {f g h : a ⟶ b} (η : f ⟶ g) (θ : g ⟶ h),
  map₂ (η ≫ θ) = map₂ η ≫ map₂ θ . obviously)
(map₂_whisker_left' : ∀ {a b c : B} (f : a ⟶ b) {g h : b ⟶ c} (η : g ⟶ h),
  map₂ (f ◁ η) = (map_comp f g).hom ≫ map f ◁ map₂ η ≫ (map_comp f h).inv . obviously)
(map₂_whisker_right' : ∀ {a b c : B} {f g : a ⟶ b} (η : f ⟶ g) (h : b ⟶ c),
  map₂ (η ▷ h) = (map_comp f h).hom ≫ map₂ η ▷ map h ≫ (map_comp g h).inv . obviously)
(map₂_associator' : ∀ {a b c d : B} (f : a ⟶ b) (g : b ⟶ c) (h : c ⟶ d),
  pseudofunctor.map₂_associator_aux obj (λ a b, map) (λ a b f g, map₂) (λ a b c, map_comp) f g h
    . obviously)
(map₂_left_unitor' : ∀ {a b : B} (f : a ⟶ b),
  map₂ (λ_ f).hom = (map_comp (𝟙 a) f).hom ≫ (map_id a).hom ▷ map f ≫ (λ_ (map f)).hom
    . obviously)
(map₂_right_unitor' : ∀ {a b : B} (f : a ⟶ b),
  map₂ (ρ_ f).hom = (map_comp f (𝟙 b)).hom ≫ map f ◁ (map_id b).hom ≫ (ρ_ (map f)).hom
    . obviously)

namespace pseudofunctor

restate_axiom map₂_id'
restate_axiom map₂_comp'
restate_axiom map₂_whisker_left'
restate_axiom map₂_whisker_right'
restate_axiom map₂_associator'
restate_axiom map₂_left_unitor'
restate_axiom map₂_right_unitor'
attribute [reassoc]
  map₂_comp map₂_whisker_left map₂_whisker_right map₂_associator map₂_left_unitor map₂_right_unitor
attribute [simp]
  map₂_id map₂_comp map₂_whisker_left map₂_whisker_right
  map₂_associator map₂_left_unitor map₂_right_unitor

section
open iso

/-- The prelax functor between the underlying quivers. -/
add_decl_doc pseudofunctor.to_prelax_functor

instance has_coe_to_prelax_functor : has_coe (pseudofunctor B C) (prelax_functor B C) :=
⟨to_prelax_functor⟩

variables (F : pseudofunctor B C)

@[simp] lemma to_prelax_functor_eq_coe : F.to_prelax_functor = F := rfl
@[simp] lemma to_prelax_functor_obj : (F : prelax_functor B C).obj = F.obj := rfl
@[simp] lemma to_prelax_functor_map : (F : prelax_functor B C).map = F.map := rfl
@[simp] lemma to_prelax_functor_map₂ : (F : prelax_functor B C).map₂ = F.map₂ := rfl

/-- The oplax functor associated with a pseudofunctor. -/
def to_oplax : oplax_functor B C :=
{ map_id := λ a, (F.map_id a).hom,
  map_comp := λ a b c f g, (F.map_comp f g).hom,
  .. (F : prelax_functor B C) }

instance has_coe_to_oplax : has_coe (pseudofunctor B C) (oplax_functor B C) := ⟨to_oplax⟩

@[simp] lemma to_oplax_eq_coe : F.to_oplax = F := rfl
@[simp] lemma to_oplax_obj : (F : oplax_functor B C).obj = F.obj := rfl
@[simp] lemma to_oplax_map : (F : oplax_functor B C).map = F.map := rfl
@[simp] lemma to_oplax_map₂ : (F : oplax_functor B C).map₂ = F.map₂ := rfl
@[simp] lemma to_oplax_map_id (a : B) : (F : oplax_functor B C).map_id a = (F.map_id a).hom := rfl
@[simp]

/-- Function on 1-morphisms as a functor. -/
@[simps]
def map_functor (a b : B) : (a ⟶ b) ⥤ (F.obj a ⟶ F.obj b) :=
(F : oplax_functor B C).map_functor a b

/-- The identity pseudofunctor. -/
@[simps]
def id (B : Type u₁) [bicategory.{w₁ v₁} B] : pseudofunctor B B :=
{ map_id := λ a, iso.refl (𝟙 a),
  map_comp := λ a b c f g, iso.refl (f ≫ g),
  .. prelax_functor.id B }

instance : inhabited (pseudofunctor B B) := ⟨id B⟩

/-- Composition of pseudofunctors. -/
@[simps]
def comp (F : pseudofunctor B C) (G : pseudofunctor C D) : pseudofunctor B D :=
{ map_id := λ a, (G.map_functor _ _).map_iso (F.map_id a) ≪≫ G.map_id (F.obj a),
  map_comp := λ a b c f g,
    (G.map_functor _ _).map_iso (F.map_comp f g) ≪≫ G.map_comp (F.map f) (F.map g),
  .. (F : prelax_functor B C).comp ↑G }

/--
Construct a pseudofunctor from an oplax functor whose `map_id` and `map_comp` are isomorphisms.
-/
@[simps]
def mk_of_oplax (F : oplax_functor B C) (F' : F.pseudo_core) : pseudofunctor B C :=
{ map_id := F'.map_id_iso,
  map_comp := F'.map_comp_iso,
  map₂_whisker_left' := λ a b c f g h η, by
  { dsimp,
    rw [F'.map_comp_iso_hom f g, ←F.map_comp_naturality_right_assoc,
      ←F'.map_comp_iso_hom f h, hom_inv_id, comp_id] },
  map₂_whisker_right' := λ a b c f g η h, by
  { dsimp,
    rw [F'.map_comp_iso_hom f h, ←F.map_comp_naturality_left_assoc,
      ←F'.map_comp_iso_hom g h, hom_inv_id, comp_id] },
  map₂_associator' := λ a b c d f g h, by
  { dsimp,
    rw [F'.map_comp_iso_hom (f ≫ g) h, F'.map_comp_iso_hom f g, ←F.map₂_associator_assoc,
      ←F'.map_comp_iso_hom f (g ≫ h), ←F'.map_comp_iso_hom g h,
      hom_inv_whisker_left_assoc, hom_inv_id, comp_id] },
  .. (F : prelax_functor B C) }

/--
Construct a pseudofunctor from an oplax functor whose `map_id` and `map_comp` are isomorphisms.
-/
@[simps]
noncomputable
def mk_of_oplax' (F : oplax_functor B C)
  [∀ a, is_iso (F.map_id a)] [∀ {a b c} (f : a ⟶ b) (g : b ⟶ c), is_iso (F.map_comp f g)] :
  pseudofunctor B C :=
{ map_id := λ a, as_iso (F.map_id a),
  map_comp := λ a b c f g, as_iso (F.map_comp f g),
  map₂_whisker_left' := λ a b c f g h η, by
  { dsimp,
    rw [←assoc, is_iso.eq_comp_inv, F.map_comp_naturality_right] },
  map₂_whisker_right' := λ a b c f g η h, by
  { dsimp,
    rw [←assoc, is_iso.eq_comp_inv, F.map_comp_naturality_left] },
  map₂_associator' := λ a b c d f g h, by
  { dsimp,
    simp only [←assoc],
    rw [is_iso.eq_comp_inv, ←inv_whisker_left, is_iso.eq_comp_inv],
    simp only [assoc, F.map₂_associator] },
  .. (F : prelax_functor B C) }

end

end pseudofunctor

end

end category_theory


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

Godel numbering for partial recursive functions.
-/
import computability.partrec

open encodable denumerable

namespace nat.partrec
open nat (mkpair)

theorem rfind' {f} (hf : nat.partrec f) : nat.partrec (nat.unpaired (λ a m,
  (nat.rfind (λ n, (λ m, m = 0) <$> f (mkpair a (n + m)))).map (+ m))) :=
partrec₂.unpaired'.2 $
begin
  refine partrec.map
    ((@partrec₂.unpaired' (λ (a b : ℕ),
      nat.rfind (λ n, (λ m, m = 0) <$> f (mkpair a (n + b))))).1 _)
    (primrec.nat_add.comp primrec.snd $
      primrec.snd.comp primrec.fst).to_comp.to₂,
  have := rfind (partrec₂.unpaired'.2 ((partrec.nat_iff.2 hf).comp
    (primrec₂.mkpair.comp
      (primrec.fst.comp $ primrec.unpair.comp primrec.fst)
      (primrec.nat_add.comp primrec.snd
        (primrec.snd.comp $ primrec.unpair.comp primrec.fst))).to_comp).to₂),
  simp at this, exact this
end

inductive code : Type
| zero : code
| succ : code
| left : code
| right : code
| pair : code → code → code
| comp : code → code → code
| prec : code → code → code
| rfind' : code → code

end nat.partrec

namespace nat.partrec.code
open nat (mkpair unpair)
open nat.partrec (code)

instance : inhabited code := ⟨zero⟩

protected def const : ℕ → code
| 0     := zero
| (n+1) := comp succ (const n)

theorem const_inj : Π {n₁ n₂}, nat.partrec.code.const n₁ = nat.partrec.code.const n₂ → n₁ = n₂
| 0 0 h := by simp
| (n₁+1) (n₂+1) h := by { dsimp [nat.partrec.code.const] at h,
                          injection h with h₁ h₂,
                          simp only [const_inj h₂] }

protected def id : code := pair left right

def curry (c : code) (n : ℕ) : code :=
comp c (pair (code.const n) code.id)

def encode_code : code → ℕ
| zero         := 0
| succ         := 1
| left         := 2
| right        := 3
| (pair cf cg) := bit0 (bit0 $ mkpair (encode_code cf) (encode_code cg)) + 4
| (comp cf cg) := bit0 (bit1 $ mkpair (encode_code cf) (encode_code cg)) + 4
| (prec cf cg) := bit1 (bit0 $ mkpair (encode_code cf) (encode_code cg)) + 4
| (rfind' cf)  := bit1 (bit1 $ encode_code cf) + 4

def of_nat_code : ℕ → code
| 0     := zero
| 1     := succ
| 2     := left
| 3     := right
| (n+4) := let m := n.div2.div2 in
  have hm : m < n + 4, by simp [m, nat.div2_val];
  from lt_of_le_of_lt
    (le_trans (nat.div_le_self _ _) (nat.div_le_self _ _))
    (nat.succ_le_succ (nat.le_add_right _ _)),
  have m1 : m.unpair.1 < n + 4, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  match n.bodd, n.div2.bodd with
  | ff, ff := pair (of_nat_code m.unpair.1) (of_nat_code m.unpair.2)
  | ff, tt := comp (of_nat_code m.unpair.1) (of_nat_code m.unpair.2)
  | tt, ff := prec (of_nat_code m.unpair.1) (of_nat_code m.unpair.2)
  | tt, tt := rfind' (of_nat_code m)
  end

private theorem encode_of_nat_code : ∀ n, encode_code (of_nat_code n) = n
| 0     := by simp [of_nat_code, encode_code]
| 1     := by simp [of_nat_code, encode_code]
| 2     := by simp [of_nat_code, encode_code]
| 3     := by simp [of_nat_code, encode_code]
| (n+4) := let m := n.div2.div2 in
  have hm : m < n + 4, by simp [m, nat.div2_val];
  from lt_of_le_of_lt
    (le_trans (nat.div_le_self _ _) (nat.div_le_self _ _))
    (nat.succ_le_succ (nat.le_add_right _ _)),
  have m1 : m.unpair.1 < n + 4, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  have IH : _ := encode_of_nat_code m,
  have IH1 : _ := encode_of_nat_code m.unpair.1,
  have IH2 : _ := encode_of_nat_code m.unpair.2,
  begin
    transitivity, swap,
    rw [← nat.bit_decomp n, ← nat.bit_decomp n.div2],
    simp [encode_code, of_nat_code, -add_comm],
    cases n.bodd; cases n.div2.bodd;
      simp [encode_code, of_nat_code, -add_comm, IH, IH1, IH2, m, nat.bit]
  end

instance : denumerable code :=
mk' ⟨encode_code, of_nat_code,
  λ c, by induction c; try {refl}; simp [
    encode_code, of_nat_code, -add_comm, *],
  encode_of_nat_code⟩

theorem encode_code_eq : encode = encode_code := rfl
theorem of_nat_code_eq : of_nat code = of_nat_code := rfl

theorem encode_lt_pair (cf cg) :
  encode cf < encode (pair cf cg) ∧
  encode cg < encode (pair cf cg) :=
begin
  simp [encode_code_eq, encode_code, -add_comm],
  have := nat.mul_le_mul_right _ (dec_trivial : 1 ≤ 2*2),
  rw [one_mul, mul_assoc, ← bit0_eq_two_mul, ← bit0_eq_two_mul] at this,
  have := lt_of_le_of_lt this (lt_add_of_pos_right _ (dec_trivial:0<4)),
  exact ⟨
    lt_of_le_of_lt (nat.le_mkpair_left _ _) this,
    lt_of_le_of_lt (nat.le_mkpair_right _ _) this⟩
end

theorem encode_lt_comp (cf cg) :
  encode cf < encode (comp cf cg) ∧
  encode cg < encode (comp cf cg) :=
begin
  suffices, exact (encode_lt_pair cf cg).imp
    (λ h, lt_trans h this) (λ h, lt_trans h this),
  change _, simp [encode_code_eq, encode_code]
end

theorem encode_lt_prec (cf cg) :
  encode cf < encode (prec cf cg) ∧
  encode cg < encode (prec cf cg) :=
begin
  suffices, exact (encode_lt_pair cf cg).imp
    (λ h, lt_trans h this) (λ h, lt_trans h this),
  change _, simp [encode_code_eq, encode_code],
end

theorem encode_lt_rfind' (cf) : encode cf < encode (rfind' cf) :=
begin
  simp [encode_code_eq, encode_code, -add_comm],
  have := nat.mul_le_mul_right _ (dec_trivial : 1 ≤ 2*2),
  rw [one_mul, mul_assoc, ← bit0_eq_two_mul, ← bit0_eq_two_mul] at this,
  refine lt_of_le_of_lt (le_trans this _)
    (lt_add_of_pos_right _ (dec_trivial:0<4)),
  exact le_of_lt (nat.bit0_lt_bit1 $ le_of_lt $
    nat.bit0_lt_bit1 $ le_refl _),
end

section
open primrec

theorem pair_prim : primrec₂ pair :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 4)

theorem comp_prim : primrec₂ comp :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit0.comp $ nat_bit1.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 4)

theorem prec_prim : primrec₂ prec :=
primrec₂.of_nat_iff.2 $ primrec₂.encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit0.comp $
    primrec₂.mkpair.comp
      (encode_iff.2 $ (primrec.of_nat code).comp fst)
      (encode_iff.2 $ (primrec.of_nat code).comp snd))
  (primrec₂.const 4)

theorem rfind_prim : primrec rfind' :=
of_nat_iff.2 $ encode_iff.1 $ nat_add.comp
  (nat_bit1.comp $ nat_bit1.comp $
    encode_iff.2 $ primrec.of_nat code)
  (const 4)

theorem rec_prim' {α σ} [primcodable α] [primcodable σ]
  {c : α → code} (hc : primrec c)
  {z : α → σ} (hz : primrec z)
  {s : α → σ} (hs : primrec s)
  {l : α → σ} (hl : primrec l)
  {r : α → σ} (hr : primrec r)
  {pr : α → code × code × σ × σ → σ} (hpr : primrec₂ pr)
  {co : α → code × code × σ × σ → σ} (hco : primrec₂ co)
  {pc : α → code × code × σ × σ → σ} (hpc : primrec₂ pc)
  {rf : α → code × σ → σ} (hrf : primrec₂ rf) :
let PR (a) := λ cf cg hf hg, pr a (cf, cg, hf, hg),
    CO (a) := λ cf cg hf hg, co a (cf, cg, hf, hg),
    PC (a) := λ cf cg hf hg, pc a (cf, cg, hf, hg),
    RF (a) := λ cf hf, rf a (cf, hf),
    F (a) (c : code) : σ := nat.partrec.code.rec_on c
      (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a) in
    primrec (λ a, F a (c a)) :=
begin
  intros,
  let G₁ : (α × list σ) × ℕ × ℕ → option σ := λ p,
    let a := p.1.1, IH := p.1.2, n := p.2.1, m := p.2.2 in
    (IH.nth m).bind $ λ s,
    (IH.nth m.unpair.1).bind $ λ s₁,
    (IH.nth m.unpair.2).map $ λ s₂,
    cond n.bodd
      (cond n.div2.bodd
        (rf a (of_nat code m, s))
        (pc a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂)))
      (cond n.div2.bodd
        (co a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂))
        (pr a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂))),
  have : primrec G₁,
  { refine option_bind (list_nth.comp (snd.comp fst) (snd.comp snd)) _,
    refine option_bind ((list_nth.comp (snd.comp fst)
      (fst.comp $ primrec.unpair.comp (snd.comp snd))).comp fst) _,
    refine option_map ((list_nth.comp (snd.comp fst)
      (snd.comp $ primrec.unpair.comp (snd.comp snd))).comp $ fst.comp fst) _,
    have a := fst.comp (fst.comp $ fst.comp $ fst.comp fst),
    have n := fst.comp (snd.comp $ fst.comp $ fst.comp fst),
    have m := snd.comp (snd.comp $ fst.comp $ fst.comp fst),
    have m₁ := fst.comp (primrec.unpair.comp m),
    have m₂ := snd.comp (primrec.unpair.comp m),
    have s := snd.comp (fst.comp fst),
    have s₁ := snd.comp fst,
    have s₂ := snd,
    exact (nat_bodd.comp n).cond
      ((nat_bodd.comp $ nat_div2.comp n).cond
        (hrf.comp a (((primrec.of_nat code).comp m).pair s))
        (hpc.comp a (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂)))
      (primrec.cond (nat_bodd.comp $ nat_div2.comp n)
        (hco.comp a (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))
        (hpr.comp a (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))) },
  let G : α → list σ → option σ := λ a IH,
    IH.length.cases (some (z a)) $ λ n,
    n.cases (some (s a)) $ λ n,
    n.cases (some (l a)) $ λ n,
    n.cases (some (r a)) $ λ n,
    G₁ ((a, IH), n, n.div2.div2),
  have : primrec₂ G := (nat_cases
    (list_length.comp snd) (option_some_iff.2 (hz.comp fst)) $
    nat_cases snd (option_some_iff.2 (hs.comp (fst.comp fst))) $
    nat_cases snd (option_some_iff.2 (hl.comp (fst.comp $ fst.comp fst))) $
    nat_cases snd (option_some_iff.2 (hr.comp (fst.comp $ fst.comp $ fst.comp fst)))
    (this.comp $
      ((fst.pair snd).comp $ fst.comp $ fst.comp $ fst.comp $ fst).pair $
      snd.pair $ nat_div2.comp $ nat_div2.comp snd)),
  refine ((nat_strong_rec
    (λ a n, F a (of_nat code n)) this.to₂ $ λ a n, _).comp
    primrec.id $ encode_iff.2 hc).of_eq (λ a, by simp),
  simp,
  iterate 4 {cases n with n, {simp [of_nat_code_eq, of_nat_code]; refl}},
  simp [G], rw [list.length_map, list.length_range],
  let m := n.div2.div2,
  show G₁ ((a, (list.range (n+4)).map (λ n, F a (of_nat code n))), n, m)
    = some (F a (of_nat code (n+4))),
  have hm : m < n + 4, by simp [nat.div2_val, m];
  from lt_of_le_of_lt
    (le_trans (nat.div_le_self _ _) (nat.div_le_self _ _))
    (nat.succ_le_succ (nat.le_add_right _ _)),
  have m1 : m.unpair.1 < n + 4, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  simp [G₁], simp [list.nth_map, list.nth_range, hm, m1, m2],
  change of_nat code (n+4) with of_nat_code (n+4),
  simp [of_nat_code],
  cases n.bodd; cases n.div2.bodd; refl
end

theorem rec_prim {α σ} [primcodable α] [primcodable σ]
  {c : α → code} (hc : primrec c)
  {z : α → σ} (hz : primrec z)
  {s : α → σ} (hs : primrec s)
  {l : α → σ} (hl : primrec l)
  {r : α → σ} (hr : primrec r)
  {pr : α → code → code → σ → σ → σ}
  (hpr : primrec (λ a : α × code × code × σ × σ,
    pr a.1 a.2.1 a.2.2.1 a.2.2.2.1 a.2.2.2.2))
  {co : α → code → code → σ → σ → σ}
  (hco : primrec (λ a : α × code × code × σ × σ,
    co a.1 a.2.1 a.2.2.1 a.2.2.2.1 a.2.2.2.2))
  {pc : α → code → code → σ → σ → σ}
  (hpc : primrec (λ a : α × code × code × σ × σ,
    pc a.1 a.2.1 a.2.2.1 a.2.2.2.1 a.2.2.2.2))
  {rf : α → code → σ → σ}
  (hrf : primrec (λ a : α × code × σ, rf a.1 a.2.1 a.2.2)) :
let F (a) (c : code) : σ := nat.partrec.code.rec_on c
      (z a) (s a) (l a) (r a) (pr a) (co a) (pc a) (rf a) in
    primrec (λ a, F a (c a)) :=
begin
  intros,
  let G₁ : (α × list σ) × ℕ × ℕ → option σ := λ p,
    let a := p.1.1, IH := p.1.2, n := p.2.1, m := p.2.2 in
    (IH.nth m).bind $ λ s,
    (IH.nth m.unpair.1).bind $ λ s₁,
    (IH.nth m.unpair.2).map $ λ s₂,
    cond n.bodd
      (cond n.div2.bodd
        (rf a (of_nat code m) s)
        (pc a (of_nat code m.unpair.1) (of_nat code m.unpair.2) s₁ s₂))
      (cond n.div2.bodd
        (co a (of_nat code m.unpair.1) (of_nat code m.unpair.2) s₁ s₂)
        (pr a (of_nat code m.unpair.1) (of_nat code m.unpair.2) s₁ s₂)),
  have : primrec G₁,
  { refine option_bind (list_nth.comp (snd.comp fst) (snd.comp snd)) _,
    refine option_bind ((list_nth.comp (snd.comp fst)
      (fst.comp $ primrec.unpair.comp (snd.comp snd))).comp fst) _,
    refine option_map ((list_nth.comp (snd.comp fst)
      (snd.comp $ primrec.unpair.comp (snd.comp snd))).comp $ fst.comp fst) _,
    have a := fst.comp (fst.comp $ fst.comp $ fst.comp fst),
    have n := fst.comp (snd.comp $ fst.comp $ fst.comp fst),
    have m := snd.comp (snd.comp $ fst.comp $ fst.comp fst),
    have m₁ := fst.comp (primrec.unpair.comp m),
    have m₂ := snd.comp (primrec.unpair.comp m),
    have s := snd.comp (fst.comp fst),
    have s₁ := snd.comp fst,
    have s₂ := snd,
    exact (nat_bodd.comp n).cond
      ((nat_bodd.comp $ nat_div2.comp n).cond
        (hrf.comp $ a.pair (((primrec.of_nat code).comp m).pair s))
        (hpc.comp $ a.pair (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂)))
      (primrec.cond (nat_bodd.comp $ nat_div2.comp n)
        (hco.comp $ a.pair (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))
        (hpr.comp $ a.pair (((primrec.of_nat code).comp m₁).pair $
          ((primrec.of_nat code).comp m₂).pair $ s₁.pair s₂))) },
  let G : α → list σ → option σ := λ a IH,
    IH.length.cases (some (z a)) $ λ n,
    n.cases (some (s a)) $ λ n,
    n.cases (some (l a)) $ λ n,
    n.cases (some (r a)) $ λ n,
    G₁ ((a, IH), n, n.div2.div2),
  have : primrec₂ G := (nat_cases
    (list_length.comp snd) (option_some_iff.2 (hz.comp fst)) $
    nat_cases snd (option_some_iff.2 (hs.comp (fst.comp fst))) $
    nat_cases snd (option_some_iff.2 (hl.comp (fst.comp $ fst.comp fst))) $
    nat_cases snd (option_some_iff.2 (hr.comp (fst.comp $ fst.comp $ fst.comp fst)))
    (this.comp $
      ((fst.pair snd).comp $ fst.comp $ fst.comp $ fst.comp $ fst).pair $
      snd.pair $ nat_div2.comp $ nat_div2.comp snd)),
  refine ((nat_strong_rec
    (λ a n, F a (of_nat code n)) this.to₂ $ λ a n, _).comp
    primrec.id $ encode_iff.2 hc).of_eq (λ a, by simp),
  simp,
  iterate 4 {cases n with n, {simp [of_nat_code_eq, of_nat_code]; refl}},
  simp [G], rw [list.length_map, list.length_range],
  let m := n.div2.div2,
  show G₁ ((a, (list.range (n+4)).map (λ n, F a (of_nat code n))), n, m)
    = some (F a (of_nat code (n+4))),
  have hm : m < n + 4, by simp [nat.div2_val, m];
  from lt_of_le_of_lt
    (le_trans (nat.div_le_self _ _) (nat.div_le_self _ _))
    (nat.succ_le_succ (nat.le_add_right _ _)),
  have m1 : m.unpair.1 < n + 4, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  simp [G₁], simp [list.nth_map, list.nth_range, hm, m1, m2],
  change of_nat code (n+4) with of_nat_code (n+4),
  simp [of_nat_code],
  cases n.bodd; cases n.div2.bodd; refl
end

end

section
open computable

/- TODO(Mario): less copy-paste from previous proof -/
theorem rec_computable {α σ} [primcodable α] [primcodable σ]
  {c : α → code} (hc : computable c)
  {z : α → σ} (hz : computable z)
  {s : α → σ} (hs : computable s)
  {l : α → σ} (hl : computable l)
  {r : α → σ} (hr : computable r)
  {pr : α → code × code × σ × σ → σ} (hpr : computable₂ pr)
  {co : α → code × code × σ × σ → σ} (hco : computable₂ co)
  {pc : α → code × code × σ × σ → σ} (hpc : computable₂ pc)
  {rf : α → code × σ → σ} (hrf : computable₂ rf) :
let PR (a) := λ cf cg hf hg, pr a (cf, cg, hf, hg),
    CO (a) := λ cf cg hf hg, co a (cf, cg, hf, hg),
    PC (a) := λ cf cg hf hg, pc a (cf, cg, hf, hg),
    RF (a) := λ cf hf, rf a (cf, hf),
    F (a) (c : code) : σ := nat.partrec.code.rec_on c
      (z a) (s a) (l a) (r a) (PR a) (CO a) (PC a) (RF a) in
    computable (λ a, F a (c a)) :=
begin
  intros,
  let G₁ : (α × list σ) × ℕ × ℕ → option σ := λ p,
    let a := p.1.1, IH := p.1.2, n := p.2.1, m := p.2.2 in
    (IH.nth m).bind $ λ s,
    (IH.nth m.unpair.1).bind $ λ s₁,
    (IH.nth m.unpair.2).map $ λ s₂,
    cond n.bodd
      (cond n.div2.bodd
        (rf a (of_nat code m, s))
        (pc a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂)))
      (cond n.div2.bodd
        (co a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂))
        (pr a (of_nat code m.unpair.1, of_nat code m.unpair.2, s₁, s₂))),
  have : computable G₁,
  { refine option_bind (list_nth.comp (snd.comp fst) (snd.comp snd)) _,
    refine option_bind ((list_nth.comp (snd.comp fst)
      (fst.comp $ computable.unpair.comp (snd.comp snd))).comp fst) _,
    refine option_map ((list_nth.comp (snd.comp fst)
      (snd.comp $ computable.unpair.comp (snd.comp snd))).comp $ fst.comp fst) _,
    have a := fst.comp (fst.comp $ fst.comp $ fst.comp fst),
    have n := fst.comp (snd.comp $ fst.comp $ fst.comp fst),
    have m := snd.comp (snd.comp $ fst.comp $ fst.comp fst),
    have m₁ := fst.comp (computable.unpair.comp m),
    have m₂ := snd.comp (computable.unpair.comp m),
    have s := snd.comp (fst.comp fst),
    have s₁ := snd.comp fst,
    have s₂ := snd,
    exact (nat_bodd.comp n).cond
      ((nat_bodd.comp $ nat_div2.comp n).cond
        (hrf.comp a (((computable.of_nat code).comp m).pair s))
        (hpc.comp a (((computable.of_nat code).comp m₁).pair $
          ((computable.of_nat code).comp m₂).pair $ s₁.pair s₂)))
      (computable.cond (nat_bodd.comp $ nat_div2.comp n)
        (hco.comp a (((computable.of_nat code).comp m₁).pair $
          ((computable.of_nat code).comp m₂).pair $ s₁.pair s₂))
        (hpr.comp a (((computable.of_nat code).comp m₁).pair $
          ((computable.of_nat code).comp m₂).pair $ s₁.pair s₂))) },
  let G : α → list σ → option σ := λ a IH,
    IH.length.cases (some (z a)) $ λ n,
    n.cases (some (s a)) $ λ n,
    n.cases (some (l a)) $ λ n,
    n.cases (some (r a)) $ λ n,
    G₁ ((a, IH), n, n.div2.div2),
  have : computable₂ G := (nat_cases
    (list_length.comp snd) (option_some_iff.2 (hz.comp fst)) $
    nat_cases snd (option_some_iff.2 (hs.comp (fst.comp fst))) $
    nat_cases snd (option_some_iff.2 (hl.comp (fst.comp $ fst.comp fst))) $
    nat_cases snd (option_some_iff.2 (hr.comp (fst.comp $ fst.comp $ fst.comp fst)))
    (this.comp $
      ((fst.pair snd).comp $ fst.comp $ fst.comp $ fst.comp $ fst).pair $
      snd.pair $ nat_div2.comp $ nat_div2.comp snd)),
  refine ((nat_strong_rec
    (λ a n, F a (of_nat code n)) this.to₂ $ λ a n, _).comp
    computable.id $ encode_iff.2 hc).of_eq (λ a, by simp),
  simp,
  iterate 4 {cases n with n, {simp [of_nat_code_eq, of_nat_code]; refl}},
  simp [G], rw [list.length_map, list.length_range],
  let m := n.div2.div2,
  show G₁ ((a, (list.range (n+4)).map (λ n, F a (of_nat code n))), n, m)
    = some (F a (of_nat code (n+4))),
  have hm : m < n + 4, by simp [nat.div2_val, m];
  from lt_of_le_of_lt
    (le_trans (nat.div_le_self _ _) (nat.div_le_self _ _))
    (nat.succ_le_succ (nat.le_add_right _ _)),
  have m1 : m.unpair.1 < n + 4, from lt_of_le_of_lt m.unpair_le_left hm,
  have m2 : m.unpair.2 < n + 4, from lt_of_le_of_lt m.unpair_le_right hm,
  simp [G₁], simp [list.nth_map, list.nth_range, hm, m1, m2],
  change of_nat code (n+4) with of_nat_code (n+4),
  simp [of_nat_code],
  cases n.bodd; cases n.div2.bodd; refl
end

end

def eval : code → ℕ →. ℕ
| zero         := pure 0
| succ         := nat.succ
| left         := ↑(λ n : ℕ, n.unpair.1)
| right        := ↑(λ n : ℕ, n.unpair.2)
| (pair cf cg) := λ n, mkpair <$> eval cf n <*> eval cg n
| (comp cf cg) := λ n, eval cg n >>= eval cf
| (prec cf cg) := nat.unpaired (λ a n,
    n.elim (eval cf a) (λ y IH, do i ← IH, eval cg (mkpair a (mkpair y i))))
| (rfind' cf)  := nat.unpaired (λ a m,
    (nat.rfind (λ n, (λ m, m = 0) <$>
      eval cf (mkpair a (n + m)))).map (+ m))

instance : has_mem (ℕ →. ℕ) code := ⟨λ f c, eval c = f⟩

@[simp] theorem eval_const : ∀ n m, eval (code.const n) m = roption.some n
| 0     m := rfl
| (n+1) m := by simp! *

@[simp] theorem eval_id (n) : eval code.id n = roption.some n := by simp! [(<*>)]

@[simp] theorem eval_curry (c n x) : eval (curry c n) x = eval c (mkpair n x) :=
by simp! [(<*>)]

theorem const_prim : primrec code.const :=
(primrec.id.nat_iterate (primrec.const zero)
  (comp_prim.comp (primrec.const succ) primrec.snd).to₂).of_eq $
λ n, by simp; induction n; simp [*, code.const, function.iterate_succ']

theorem curry_prim : primrec₂ curry :=
comp_prim.comp primrec.fst $
pair_prim.comp (const_prim.comp primrec.snd) (primrec.const code.id)

theorem curry_inj {c₁ c₂ n₁ n₂} (h : curry c₁ n₁ = curry c₂ n₂) : c₁ = c₂ ∧ n₁ = n₂ :=
⟨by injection h, by { injection h,
                      injection h with h₁ h₂,
                      injection h₂ with h₃ h₄,
                      exact const_inj h₃ }⟩

theorem smn : ∃ f : code → ℕ → code,
  computable₂ f ∧ ∀ c n x, eval (f c n) x = eval c (mkpair n x) :=
⟨curry, primrec₂.to_comp curry_prim, eval_curry⟩

theorem exists_code {f : ℕ →. ℕ} : nat.partrec f ↔ ∃ c : code, eval c = f :=
⟨λ h, begin
  induction h,
  case nat.partrec.zero { exact ⟨zero, rfl⟩ },
  case nat.partrec.succ { exact ⟨succ, rfl⟩ },
  case nat.partrec.left { exact ⟨left, rfl⟩ },
  case nat.partrec.right { exact ⟨right, rfl⟩ },
  case nat.partrec.pair : f g pf pg hf hg {
    rcases hf with ⟨cf, rfl⟩, rcases hg with ⟨cg, rfl⟩,
    exact ⟨pair cf cg, rfl⟩ },
  case nat.partrec.comp : f g pf pg hf hg {
    rcases hf with ⟨cf, rfl⟩, rcases hg with ⟨cg, rfl⟩,
    exact ⟨comp cf cg, rfl⟩ },
  case nat.partrec.prec : f g pf pg hf hg {
    rcases hf with ⟨cf, rfl⟩, rcases hg with ⟨cg, rfl⟩,
    exact ⟨prec cf cg, rfl⟩ },
  case nat.partrec.rfind : f pf hf {
    rcases hf with ⟨cf, rfl⟩,
    refine ⟨comp (rfind' cf) (pair code.id zero), _⟩,
    simp [eval, (<*>), pure, pfun.pure, roption.map_id'] },
end, λ h, begin
  rcases h with ⟨c, rfl⟩, induction c,
  case nat.partrec.code.zero { exact nat.partrec.zero },
  case nat.partrec.code.succ { exact nat.partrec.succ },
  case nat.partrec.code.left { exact nat.partrec.left },
  case nat.partrec.code.right { exact nat.partrec.right },
  case nat.partrec.code.pair : cf cg pf pg { exact pf.pair pg },
  case nat.partrec.code.comp : cf cg pf pg { exact pf.comp pg },
  case nat.partrec.code.prec : cf cg pf pg { exact pf.prec pg },
  case nat.partrec.code.rfind' : cf pf { exact pf.rfind' },
end⟩

def evaln : ∀ k : ℕ, code → ℕ → option ℕ
| 0     _            := λ m, none
| (k+1) zero         := λ n, guard (n ≤ k) >> pure 0
| (k+1) succ         := λ n, guard (n ≤ k) >> pure (nat.succ n)
| (k+1) left         := λ n, guard (n ≤ k) >> pure n.unpair.1
| (k+1) right        := λ n, guard (n ≤ k) >> pure n.unpair.2
| (k+1) (pair cf cg) := λ n, guard (n ≤ k) >>
  mkpair <$> evaln (k+1) cf n <*> evaln (k+1) cg n
| (k+1) (comp cf cg) := λ n, guard (n ≤ k) >>
  do x ← evaln (k+1) cg n, evaln (k+1) cf x
| (k+1) (prec cf cg) := λ n, guard (n ≤ k) >>
  n.unpaired (λ a n,
  n.cases (evaln (k+1) cf a) $ λ y, do
    i ← evaln k (prec cf cg) (mkpair a y),
    evaln (k+1) cg (mkpair a (mkpair y i)))
| (k+1) (rfind' cf)  := λ n, guard (n ≤ k) >>
  n.unpaired (λ a m, do
  x ← evaln (k+1) cf (mkpair a m),
  if x = 0 then pure m else
  evaln k (rfind' cf) (mkpair a (m+1)))

theorem evaln_bound : ∀ {k c n x}, x ∈ evaln k c n → n < k
| 0     c n x h := by simp [evaln] at h; cases h
| (k+1) c n x h := begin
  suffices : ∀ {o : option ℕ}, x ∈ guard (n ≤ k) >> o → n < k + 1,
  { cases c; rw [evaln] at h; exact this h },
  simpa [(>>)] using nat.lt_succ_of_le
end

theorem evaln_mono : ∀ {k₁ k₂ c n x}, k₁ ≤ k₂ → x ∈ evaln k₁ c n → x ∈ evaln k₂ c n
| 0     k₂     c n x hl h := by simp [evaln] at h; cases h
| (k+1) (k₂+1) c n x hl h := begin
  have hl' := nat.le_of_succ_le_succ hl,
  have : ∀ {k k₂ n x : ℕ} {o₁ o₂ : option ℕ},
    k ≤ k₂ → (x ∈ o₁ → x ∈ o₂) → x ∈ guard (n ≤ k) >> o₁ → x ∈ guard (n ≤ k₂) >> o₂,
  { simp [(>>)], introv h h₁ h₂ h₃, exact ⟨le_trans h₂ h, h₁ h₃⟩ },
  simp at h ⊢,
  induction c with cf cg hf hg cf cg hf hg cf cg hf hg cf hf generalizing x n;
    rw [evaln] at h ⊢; refine this hl' (λ h, _) h,
  iterate 4 {exact h},
  { -- pair cf cg
    simp [(<*>)] at h ⊢,
    exact h.imp (λ a, and.imp (hf _ _) $ Exists.imp $ λ b, and.imp_left (hg _ _)) },
  { -- comp cf cg
    simp at h ⊢,
    exact h.imp (λ a, and.imp (hg _ _) (hf _ _)) },
  { -- prec cf cg
    revert h, simp,
    induction n.unpair.2; simp,
    { apply hf },
    { exact λ y h₁ h₂, ⟨y, evaln_mono hl' h₁, hg _ _ h₂⟩ } },
  { -- rfind' cf
    simp at h ⊢,
    refine h.imp (λ x, and.imp (hf _ _) _),
    by_cases x0 : x = 0; simp [x0],
    exact evaln_mono hl' }
end

theorem evaln_sound : ∀ {k c n x}, x ∈ evaln k c n → x ∈ eval c n
| 0     _ n x h := by simp [evaln] at h; cases h
| (k+1) c n x h := begin
  induction c with cf cg hf hg cf cg hf hg cf cg hf hg cf hf generalizing x n;
    simp [eval, evaln, (>>), (<*>)] at h ⊢; cases h with _ h,
  iterate 4 {simpa [pure, pfun.pure, eq_comm] using h},
  { -- pair cf cg
    rcases h with ⟨y, ef, z, eg, rfl⟩,
    exact ⟨_, hf _ _ ef, _, hg _ _ eg, rfl⟩ },
  { --comp hf hg
    rcases h with ⟨y, eg, ef⟩,
    exact ⟨_, hg _ _ eg, hf _ _ ef⟩ },
  { -- prec cf cg
    revert h,
    induction n.unpair.2 with m IH generalizing x; simp,
    { apply hf },
    { refine λ y h₁ h₂, ⟨y, IH _ _, _⟩,
      { have := evaln_mono k.le_succ h₁,
        simp [evaln, (>>)] at this,
        exact this.2 },
      { exact hg _ _ h₂ } } },
  { -- rfind' cf
    rcases h with ⟨m, h₁, h₂⟩,
    by_cases m0 : m = 0; simp [m0] at h₂,
    { exact ⟨0,
       ⟨by simpa [m0] using hf _ _ h₁,
        λ m, (nat.not_lt_zero _).elim⟩,
        by injection h₂ with h₂; simp [h₂]⟩ },
    { have := evaln_sound h₂, simp [eval] at this,
      rcases this with ⟨y, ⟨hy₁, hy₂⟩, rfl⟩,
      refine ⟨ y+1, ⟨by simpa [add_comm, add_left_comm] using hy₁, λ i im, _⟩,
               by simp [add_comm, add_left_comm] ⟩,
      cases i with i,
      { exact ⟨m, by simpa using hf _ _ h₁, m0⟩ },
      { rcases hy₂ (nat.lt_of_succ_lt_succ im) with ⟨z, hz, z0⟩,
        exact ⟨z, by simpa [nat.succ_eq_add_one, add_comm, add_left_comm] using hz, z0⟩ } } }
end

theorem evaln_complete {c n x} : x ∈ eval c n ↔ ∃ k, x ∈ evaln k c n :=
⟨λ h, begin
  suffices : ∃ k, x ∈ evaln (k+1) c n,
  { exact let ⟨k, h⟩ := this in ⟨k+1, h⟩ },
  induction c generalizing n x;
    simp [eval, evaln, pure, pfun.pure, (<*>), (>>)] at h ⊢,
  iterate 4 { exact ⟨⟨_, le_refl _⟩, h.symm⟩ },
  case nat.partrec.code.pair : cf cg hf hg {
    rcases h with ⟨x, hx, y, hy, rfl⟩,
    rcases hf hx with ⟨k₁, hk₁⟩, rcases hg hy with ⟨k₂, hk₂⟩,
    refine ⟨max k₁ k₂, _⟩,
    refine ⟨le_max_left_of_le $ nat.le_of_lt_succ $ evaln_bound hk₁,
      _, evaln_mono (nat.succ_le_succ $ le_max_left _ _) hk₁,
      _, evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂, rfl⟩ },
  case nat.partrec.code.comp : cf cg hf hg {
    rcases h with ⟨y, hy, hx⟩,
    rcases hg hy with ⟨k₁, hk₁⟩, rcases hf hx with ⟨k₂, hk₂⟩,
    refine ⟨max k₁ k₂, _⟩,
    exact ⟨le_max_left_of_le $ nat.le_of_lt_succ $ evaln_bound hk₁, _,
      evaln_mono (nat.succ_le_succ $ le_max_left _ _) hk₁,
      evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂⟩ },
  case nat.partrec.code.prec : cf cg hf hg {
    revert h,
    generalize : n.unpair.1 = n₁, generalize : n.unpair.2 = n₂,
    induction n₂ with m IH generalizing x n; simp,
    { intro, rcases hf h with ⟨k, hk⟩,
      exact ⟨_, le_max_left _ _,
        evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk⟩ },
    { intros y hy hx,
      rcases IH hy with ⟨k₁, nk₁, hk₁⟩, rcases hg hx with ⟨k₂, hk₂⟩,
      refine ⟨(max k₁ k₂).succ, nat.le_succ_of_le $ le_max_left_of_le $
        le_trans (le_max_left _ (mkpair n₁ m)) nk₁, y,
        evaln_mono (nat.succ_le_succ $ le_max_left _ _) _,
        evaln_mono (nat.succ_le_succ $ nat.le_succ_of_le $ le_max_right _ _) hk₂⟩,
      simp [evaln, (>>)],
      exact ⟨le_trans (le_max_right _ _) nk₁, hk₁⟩ } },
  case nat.partrec.code.rfind' : cf hf {
    rcases h with ⟨y, ⟨hy₁, hy₂⟩, rfl⟩,
    suffices : ∃ k, y + n.unpair.2 ∈ evaln (k+1) (rfind' cf)
      (mkpair n.unpair.1 n.unpair.2), {simpa [evaln, (>>)]},
    revert hy₁ hy₂, generalize : n.unpair.2 = m, intros,
    induction y with y IH generalizing m; simp [evaln, (>>)],
    { simp at hy₁, rcases hf hy₁ with ⟨k, hk⟩,
      exact ⟨_, nat.le_of_lt_succ $ evaln_bound hk, _, hk, by simp; refl⟩ },
    { rcases hy₂ (nat.succ_pos _) with ⟨a, ha, a0⟩,
      rcases hf ha with ⟨k₁, hk₁⟩,
      rcases IH m.succ
          (by simpa [nat.succ_eq_add_one, add_comm, add_left_comm] using hy₁)
          (λ i hi, by simpa [nat.succ_eq_add_one, add_comm, add_left_comm] using
            hy₂ (nat.succ_lt_succ hi))
        with ⟨k₂, hk₂⟩,
      use (max k₁ k₂).succ,
      rw [zero_add] at hk₁,
      use (nat.le_succ_of_le $ le_max_left_of_le $ nat.le_of_lt_succ $ evaln_bound hk₁),
      use a,
      use evaln_mono (nat.succ_le_succ $ nat.le_succ_of_le $ le_max_left _ _) hk₁,
      simpa [nat.succ_eq_add_one, a0, -max_eq_left, -max_eq_right, add_comm, add_left_comm] using
          evaln_mono (nat.succ_le_succ $ le_max_right _ _) hk₂ } }
end, λ ⟨k, h⟩, evaln_sound h⟩

section
open primrec

private def lup (L : list (list (option ℕ))) (p : ℕ × code) (n : ℕ) :=
do l ← L.nth (encode p), o ← l.nth n, o

private lemma hlup : primrec (λ p:_×(_×_)×_, lup p.1 p.2.1 p.2.2) :=
option_bind
  (list_nth.comp fst (primrec.encode.comp $ fst.comp snd))
  (option_bind (list_nth.comp snd $ snd.comp $ snd.comp fst) snd)

private def G (L : list (list (option ℕ))) : option (list (option ℕ)) :=
option.some $
let a := of_nat (ℕ × code) L.length,
    k := a.1, c := a.2 in
(list.range k).map (λ n,
  k.cases none $ λ k',
  nat.partrec.code.rec_on c
    (some 0) -- zero
    (some (nat.succ n))
    (some n.unpair.1)
    (some n.unpair.2)
    (λ cf cg _ _, do
      x ← lup L (k, cf) n,
      y ← lup L (k, cg) n,
      some (mkpair x y))
    (λ cf cg _ _, do
      x ← lup L (k, cg) n,
      lup L (k, cf) x)
    (λ cf cg _ _,
      let z := n.unpair.1 in
      n.unpair.2.cases
        (lup L (k, cf) z)
        (λ y, do
          i ← lup L (k', c) (mkpair z y),
          lup L (k, cg) (mkpair z (mkpair y i))))
    (λ cf _,
      let z := n.unpair.1, m := n.unpair.2 in do
      x ← lup L (k, cf) (mkpair z m),
      x.cases
        (some m)
        (λ _, lup L (k', c) (mkpair z (m+1)))))

private lemma hG : primrec G :=
begin
  have a := (primrec.of_nat (ℕ × code)).comp list_length,
  have k := fst.comp a,
  refine option_some.comp
    (list_map (list_range.comp k) (_ : primrec _)),
  replace k := k.comp fst, have n := snd,
  refine nat_cases k (const none) (_ : primrec _),
  have k := k.comp fst, have n := n.comp fst, have k' := snd,
  have c := snd.comp (a.comp $ fst.comp fst),
  apply rec_prim c
    (const (some 0))
    (option_some.comp (primrec.succ.comp n))
    (option_some.comp (fst.comp $ primrec.unpair.comp n))
    (option_some.comp (snd.comp $ primrec.unpair.comp n)),
  { have L := (fst.comp fst).comp fst,
    have k := k.comp fst, have n := n.comp fst,
    have cf := fst.comp snd,
    have cg := (fst.comp snd).comp snd,
    exact option_bind
      (hlup.comp $ L.pair $ (k.pair cf).pair n)
      (option_map ((hlup.comp $
        L.pair $ (k.pair cg).pair n).comp fst)
        (primrec₂.mkpair.comp (snd.comp fst) snd)) },
  { have L := (fst.comp fst).comp fst,
    have k := k.comp fst, have n := n.comp fst,
    have cf := fst.comp snd,
    have cg := (fst.comp snd).comp snd,
    exact option_bind
      (hlup.comp $ L.pair $ (k.pair cg).pair n)
      (hlup.comp ((L.comp fst).pair $
        ((k.pair cf).comp fst).pair snd)) },
  { have L := (fst.comp fst).comp fst,
    have k := k.comp fst, have n := n.comp fst,
    have cf := fst.comp snd,
    have cg := (fst.comp snd).comp snd,
    have z := fst.comp (primrec.unpair.comp n),
    refine nat_cases
      (snd.comp (primrec.unpair.comp n))
      (hlup.comp $ L.pair $ (k.pair cf).pair z)
      (_ : primrec _),
    have L := L.comp fst, have z := z.comp fst, have y := snd,
    refine option_bind
      (hlup.comp $ L.pair $
        (((k'.pair c).comp fst).comp fst).pair
        (primrec₂.mkpair.comp z y))
      (_ : primrec _),
    have z := z.comp fst, have y := y.comp fst, have i := snd,
    exact hlup.comp ((L.comp fst).pair $
      ((k.pair cg).comp $ fst.comp fst).pair $
      primrec₂.mkpair.comp z $ primrec₂.mkpair.comp y i) },
  { have L := (fst.comp fst).comp fst,
    have k := k.comp fst, have n := n.comp fst,
    have cf := fst.comp snd,
    have z := fst.comp (primrec.unpair.comp n),
    have m := snd.comp (primrec.unpair.comp n),
    refine option_bind
      (hlup.comp $ L.pair $ (k.pair cf).pair (primrec₂.mkpair.comp z m))
      (_ : primrec _),
    have m := m.comp fst,
    exact nat_cases snd (option_some.comp m)
      ((hlup.comp ((L.comp fst).pair $
        ((k'.pair c).comp $ fst.comp fst).pair
        (primrec₂.mkpair.comp (z.comp fst)
          (primrec.succ.comp m)))).comp fst) }
end

private lemma evaln_map (k c n) :
  (((list.range k).nth n).map (evaln k c)).bind (λ b, b) = evaln k c n :=
begin
  by_cases kn : n < k,
  { simp [list.nth_range kn] },
  { rw list.nth_len_le,
    { cases e : evaln k c n, {refl},
      exact kn.elim (evaln_bound e) },
    simpa using kn }
end

theorem evaln_prim : primrec (λ (a : (ℕ × code) × ℕ), evaln a.1.1 a.1.2 a.2) :=
have primrec₂ (λ (_:unit) (n : ℕ),
  let a := of_nat (ℕ × code) n in
  (list.range a.1).map (evaln a.1 a.2)), from
primrec.nat_strong_rec _ (hG.comp snd).to₂ $
  λ _ p, begin
    simp [G],
    rw (_ : (of_nat (ℕ × code) _).snd =
      of_nat code p.unpair.2), swap, {simp},
    apply list.map_congr (λ n, _),
    rw (by simp : list.range p = list.range
      (mkpair p.unpair.1 (encode (of_nat code p.unpair.2)))),
    generalize : p.unpair.1 = k,
    generalize : of_nat code p.unpair.2 = c,
    intro nk,
    cases k with k', {simp [evaln]},
    let k := k'+1, change k'.succ with k,
    simp [nat.lt_succ_iff] at nk,
    have hg : ∀ {k' c' n},
      mkpair k' (encode c') < mkpair k (encode c) →
      lup ((list.range (mkpair k (encode c))).map (λ n,
        (list.range n.unpair.1).map
          (evaln n.unpair.1 (of_nat code n.unpair.2))))
        (k', c') n = evaln k' c' n,
    { intros k₁ c₁ n₁ hl,
      simp [lup, list.nth_range hl, evaln_map, (>>=)] },
    cases c with cf cg cf cg cf cg cf;
      simp [evaln, nk, (>>), (>>=), (<$>), (<*>), pure],
    { cases encode_lt_pair cf cg with lf lg,
      rw [hg (nat.mkpair_lt_mkpair_right _ lf),
          hg (nat.mkpair_lt_mkpair_right _ lg)],
      cases evaln k cf n, {refl},
      cases evaln k cg n; refl },
    { cases encode_lt_comp cf cg with lf lg,
      rw hg (nat.mkpair_lt_mkpair_right _ lg),
      cases evaln k cg n, {refl},
      simp [hg (nat.mkpair_lt_mkpair_right _ lf)] },
    { cases encode_lt_prec cf cg with lf lg,
      rw hg (nat.mkpair_lt_mkpair_right _ lf),
      cases n.unpair.2, {refl},
      simp,
      rw hg (nat.mkpair_lt_mkpair_left _ k'.lt_succ_self),
      cases evaln k' _ _, {refl},
      simp [hg (nat.mkpair_lt_mkpair_right _ lg)] },
    { have lf := encode_lt_rfind' cf,
      rw hg (nat.mkpair_lt_mkpair_right _ lf),
      cases evaln k cf n with x, {refl},
      simp,
      cases x; simp [nat.succ_ne_zero],
      rw hg (nat.mkpair_lt_mkpair_left _ k'.lt_succ_self) }
  end,
(option_bind (list_nth.comp
  (this.comp (const ()) (encode_iff.2 fst)) snd)
  snd.to₂).of_eq $ λ ⟨⟨k, c⟩, n⟩, by simp [evaln_map]

end

section
open partrec computable

theorem eval_part : partrec₂ eval :=
(rfind_opt (evaln_prim.to_comp.comp
  ((snd.pair (fst.comp fst)).pair (snd.comp fst))).to₂).of_eq $
λ a, by simp [eval_eq_rfind_opt]

theorem fixed_point
  {f : code → code} (hf : computable f) : ∃ c : code, eval (f c) = eval c :=
let g (x y : ℕ) : roption ℕ :=
  eval (of_nat code x) x >>= λ b, eval (of_nat code b) y in
have partrec₂ g :=
  (eval_part.comp ((computable.of_nat _).comp fst) fst).bind
  (eval_part.comp ((computable.of_nat _).comp snd) (snd.comp fst)).to₂,
let ⟨cg, eg⟩ := exists_code.1 this in
have eg' : ∀ a n, eval cg (mkpair a n) = roption.map encode (g a n) :=
  by simp [eg],
let F (x : ℕ) : code := f (curry cg x) in
have computable F :=
  hf.comp (curry_prim.comp (primrec.const cg) primrec.id).to_comp,
let ⟨cF, eF⟩ := exists_code.1 this in
have eF' : eval cF (encode cF) = roption.some (encode (F (encode cF))),
  by simp [eF],
⟨curry cg (encode cF), funext (λ n,
  show eval (f (curry cg (encode cF))) n = eval (curry cg (encode cF)) n,
  by simp [eg', eF', roption.map_id', g])⟩

theorem fixed_point₂
  {f : code → ℕ →. ℕ} (hf : partrec₂ f) : ∃ c : code, eval c = f c :=
let ⟨cf, ef⟩ := exists_code.1 hf in
(fixed_point (curry_prim.comp
  (primrec.const cf) primrec.encode).to_comp).imp $
λ c e, funext $ λ n, by simp [e.symm, ef, roption.map_id']

end

end nat.partrec.code


example (p q r : Prop) (hp : p) :
(p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) :=
by split; try{split}; repeat {{left, assumption} <|> right <|> assumption}


import condensed.ab
import rescale.pseudo_normed_group
import hacks_and_tricks.asyncI
import for_mathlib.Profinite.extend
import facts.nnreal

.

noncomputable theory

universe u

open_locale nnreal
open category_theory

namespace comphaus_filtered_pseudo_normed_group

def of_rescale_one_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom (rescale 1 M) M :=
{ continuous' := λ c, comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * 1⁻¹) c,
  .. rescale.of_rescale_one_strict_pseudo_normed_group_hom M
}

def to_rescale_one_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom M (rescale 1 M) :=
{ continuous' := λ c, begin
    haveI : fact (c ≤ c * 1⁻¹) := ⟨le_of_eq (by rw [inv_one, mul_one])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le c (c * 1⁻¹),
  end,
  .. rescale.to_rescale_one_strict_pseudo_normed_group_hom M
}

def of_rescale_eq_strict (M : Type*) [comphaus_filtered_pseudo_normed_group M]
  (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] (hrr' : r = r') :
strict_comphaus_filtered_pseudo_normed_group_hom (rescale r M) (rescale r' M) :=
{ continuous' := λ c, begin
  haveI : fact (c * r⁻¹ ≤ c * r'⁻¹) := ⟨le_of_eq (by rw hrr')⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * r⁻¹) (c * r'⁻¹),
  end,
  .. rescale.of_rescale_eq_strict_pseudo_normed_group_hom  r r' M hrr',
}

def of_rescale_rescale_strict (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')]
  (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom
    (rescale r (rescale r' M)) (rescale (r' * r) M) :=
{
  continuous' := λ c,
  begin
    haveI : fact (c * r⁻¹ * r'⁻¹ ≤ c * (r' * r)⁻¹) :=
      ⟨le_of_eq (by rw [mul_inv_rev, mul_assoc])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * r⁻¹ * r'⁻¹) _,
  end,
  ..rescale.of_rescale_rescale_strict_pseudo_normed_group_hom r r' M
}

def to_rescale_rescale_strict (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')]
  (M : Type*) [comphaus_filtered_pseudo_normed_group M] :
  strict_comphaus_filtered_pseudo_normed_group_hom
    (rescale (r' * r) M) (rescale r (rescale r' M)) :=
{
  continuous' := λ c,
  begin
    haveI : fact (c * (r' * r)⁻¹ ≤ c * r⁻¹ * r'⁻¹) :=
      ⟨le_of_eq (by rw [mul_inv_rev, mul_assoc])⟩,
    exact comphaus_filtered_pseudo_normed_group.continuous_cast_le (c * (r' * r)⁻¹) _,
  end,
  ..rescale.to_rescale_rescale_strict_pseudo_normed_group_hom r r' M
}

end comphaus_filtered_pseudo_normed_group

namespace CompHausFiltPseuNormGrp

@[simps]
def rescale (r : ℝ≥0) : CompHausFiltPseuNormGrp ⥤ CompHausFiltPseuNormGrp :=
{ obj := λ M, of (rescale r M),
  map := λ M₁ M₂ f, rescale.map_comphaus_filtered_pseudo_normed_group_hom r f,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }
.

def rescale_iso_component (r : ℝ≥0) [fact (0 < r)] (M : CompHausFiltPseuNormGrp) :
  (rescale r).obj M ≅ M :=
{ hom :=
  comphaus_filtered_pseudo_normed_group_hom.mk' (add_monoid_hom.id _)
  begin
    refine ⟨r⁻¹, λ c, ⟨_, _⟩⟩,
    { intros x hx,
      refine pseudo_normed_group.filtration_mono _ hx,
      rw mul_comm },
    { convert @comphaus_filtered_pseudo_normed_group.continuous_cast_le M _ _ _ _ using 1,
      rw mul_comm, apply_instance }
  end,
  inv :=
  comphaus_filtered_pseudo_normed_group_hom.mk' (add_monoid_hom.id _)
  begin
    have hr : r ≠ 0 := ne_of_gt (fact.out _),
    refine ⟨r, λ c, ⟨_, _⟩⟩,
    { intros x hx,
      dsimp, erw rescale.mem_filtration,
      refine pseudo_normed_group.filtration_mono _ hx,
      rw [mul_comm, inv_mul_cancel_left₀ hr], },
    { convert @comphaus_filtered_pseudo_normed_group.continuous_cast_le M _ _ _ _ using 1,
      rw [mul_comm, inv_mul_cancel_left₀ hr], apply_instance }
  end,
  hom_inv_id' := by { intros, ext, refl },
  inv_hom_id' := by { intros, ext, refl } }

def rescale_iso (r : ℝ≥0) [fact (0 < r)] : rescale r ≅ 𝟭 _ :=
nat_iso.of_components (rescale_iso_component r) $ λ _ _ _, rfl

-- instance (X : Profinite) (c : ℝ≥0) [fact (0 < c)] :
--   limits.preserves_limits (rescale c) :=
-- limits.preserves_limits_of_nat_iso (rescale_iso c).symm

instance rescale_preserves_limits_of_shape_discrete_quotient
  (X : Profinite.{u}) (c : ℝ≥0) [fact (0 < c)] :
  limits.preserves_limits_of_shape.{u u u u u+1 u+1} (discrete_quotient.{u} ↥X) (rescale.{u u} c) :=
limits.preserves_limits_of_shape_of_nat_iso (rescale_iso c).symm

def rescale₁ (r : ℝ≥0) [fact (0 < r)] (M : CompHausFiltPseuNormGrp)
  (exh : ∀ m : M, ∃ c, m ∈ pseudo_normed_group.filtration M c) :
  CompHausFiltPseuNormGrp₁ :=
{ M := _root_.rescale r M,
  exhaustive' := λ m, begin
    obtain ⟨c, hc⟩ := exh (rescale.of.symm m),
    simp only [rescale.mem_filtration],
    refine ⟨c * r, pseudo_normed_group.filtration_mono _ hc⟩,
    rw mul_inv_cancel_right₀, exact ne_of_gt (fact.out _),
  end }

end CompHausFiltPseuNormGrp

namespace CompHausFiltPseuNormGrp₁

@[simps]
def rescale (r : ℝ≥0) [fact (0 < r)] : CompHausFiltPseuNormGrp₁ ⥤ CompHausFiltPseuNormGrp₁ :=
{ obj := λ M,
  { M := rescale r M,
    exhaustive' := λ m, begin
      obtain ⟨c, hc⟩ := M.exhaustive (rescale.of.symm m),
      simp only [rescale.mem_filtration],
      refine ⟨c * r, pseudo_normed_group.filtration_mono _ hc⟩,
      rw mul_inv_cancel_right₀, exact ne_of_gt (fact.out _),
    end },
  map := λ M₁ M₂ f, rescale.map_strict_comphaus_filtered_pseudo_normed_group_hom r f,
  map_id' := by { intros, ext, refl },
  map_comp' := by { intros, ext, refl } }
.

instance rescale.equivalence (r : ℝ≥0) [fact (0 < r)] :
  is_equivalence (rescale r) :=
by haveI : fact (0 < r⁻¹) := ⟨nnreal.inv_pos.2 (fact.elim infer_instance)⟩;
   haveI : fact (0 < r * r⁻¹) := ⟨mul_pos (fact.elim infer_instance) (fact.elim infer_instance)⟩;
exactI
is_equivalence.mk (@rescale r⁻¹ ⟨nnreal.inv_pos.2 (fact.elim infer_instance)⟩)
{ hom :=
  { app := λ M,
    -- M ⟶ rescale 1 M ⟶ rescale (r * r⁻¹) M ⟶ rescale r⁻¹ (rescale r M)
    ((comphaus_filtered_pseudo_normed_group.to_rescale_rescale_strict r⁻¹ r M).comp
    ((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M 1 (r * r⁻¹)
      (eq.symm (mul_inv_cancel (ne_of_gt (fact.elim infer_instance))))))).comp
    (comphaus_filtered_pseudo_normed_group.to_rescale_one_strict M),
    naturality' := λ M N f, rfl,
  },
  inv :=
  { app := λ M,
    -- rescale r⁻¹ (rescale r M) ⟶ rescale (r * r⁻¹) M ⟶ rescale 1 M ⟶ M
    (comphaus_filtered_pseudo_normed_group.of_rescale_one_strict M).comp
    (((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M (r * r⁻¹) 1
      ((mul_inv_cancel (ne_of_gt (fact.elim infer_instance)))))).comp
      (comphaus_filtered_pseudo_normed_group.of_rescale_rescale_strict r⁻¹ r M)),
    naturality' := λ M N f, rfl },
  hom_inv_id' := rfl,
  inv_hom_id' := rfl }
  { hom :=
    { app := λ M,
    -- rescale r (rescale r⁻¹ M) ⟶ rescale (r⁻¹ * r) M ⟶ rescale 1 M ⟶ M
    (comphaus_filtered_pseudo_normed_group.of_rescale_one_strict M).comp
    (((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M (r⁻¹ * r) 1
      ((inv_mul_cancel (ne_of_gt (fact.elim infer_instance)))))).comp
      (comphaus_filtered_pseudo_normed_group.of_rescale_rescale_strict r r⁻¹ M)),
      naturality' := λ M N f, rfl },
    inv :=
    { app := λ M,
    -- M ⟶ rescale 1 M ⟶ rescale (r⁻¹ * r) M ⟶ rescale r (rescale r⁻¹ M)
    ((comphaus_filtered_pseudo_normed_group.to_rescale_rescale_strict r r⁻¹ M).comp
    ((comphaus_filtered_pseudo_normed_group.of_rescale_eq_strict M 1 (r⁻¹ * r)
      (eq.symm (inv_mul_cancel (ne_of_gt (fact.elim infer_instance))))))).comp
    (comphaus_filtered_pseudo_normed_group.to_rescale_one_strict M),
      naturality' := λ M N f, rfl },
    hom_inv_id' := rfl,
    inv_hom_id' := rfl }

instance rescale_preserves_limits_of_shape_discrete_quotient
  (X : Profinite.{u}) (c : ℝ≥0) [fact (0 < c)] :
  limits.preserves_limits_of_shape.{u u u u u+1 u+1} (discrete_quotient.{u} ↥X) (rescale.{u u} c) :=
begin
  let foo := (category_theory.adjunction.is_equivalence_preserves_limits
    (rescale c)).preserves_limits_of_shape,
  exact foo, -- not 100% sure why I need to define foo first
end

@[simps]
def rescale_enlarging_iso (r : ℝ≥0) [fact (0 < r)] :
  rescale r ⋙ CHFPNG₁_to_CHFPNGₑₗ ≅ CHFPNG₁_to_CHFPNGₑₗ :=
begin
  refine _ ≪≫ (iso_whisker_left _ (CompHausFiltPseuNormGrp.rescale_iso r))
    ≪≫ functor.right_unitor _,
  exact nat_iso.of_components (λ M, iso.refl _) (λ _ _ _, rfl),
end

@[simps]
def rescale_to_Condensed_iso (r : ℝ≥0) [fact (0 < r)] :
  rescale r ⋙ to_Condensed ≅
  CHFPNG₁_to_CHFPNGₑₗ ⋙ CompHausFiltPseuNormGrp.rescale r ⋙ CompHausFiltPseuNormGrp.to_Condensed :=
nat_iso.of_components (λ M, iso.refl _) $ λ _ _ _, rfl

-- @[simps]
-- def strict_unscale (r : ℝ≥0) [fact (1 ≤ r)] :
--   rescale r ⟶ 𝟭 _ :=
-- { app := λ M, comphaus_filtered_pseudo_normed_group.strict_unscale M r,
--   naturality' := by { intros, ext, refl, } }

-- def Condensed_unscale (r : ℝ≥0) [fact (1 ≤ r)] :
--   rescale r ⋙ to_Condensed ⟶ to_Condensed :=
-- whisker_right (strict_unscale r) to_Condensed ≫ (functor.left_unitor _).hom

-- instance is_iso_strict_unscale (r : ℝ≥0) [fact (1 ≤ r)] (M) :
--   is_iso ((Condensed_unscale r).app M) :=
-- begin
--   admit
-- end

end CompHausFiltPseuNormGrp₁

namespace comphaus_filtered_pseudo_normed_group_hom

def strictify (M₁ M₂ : Type*)
  [comphaus_filtered_pseudo_normed_group M₁] [comphaus_filtered_pseudo_normed_group M₂]
  (f : comphaus_filtered_pseudo_normed_group_hom M₁ M₂)
  (r : ℝ≥0) [fact (0 < r)]
  (hf : f.bound_by r) :
  strict_comphaus_filtered_pseudo_normed_group_hom (rescale r M₁) M₂ :=
strict_comphaus_filtered_pseudo_normed_group_hom.mk' (f.to_add_monoid_hom)
begin
  intro c,
  refine ⟨λ x hx, pseudo_normed_group.filtration_mono _ (hf hx), f.continuous _ (λ _, rfl)⟩,
  have hr : r ≠ 0 := ne_of_gt (fact.out _),
  rw [mul_left_comm, mul_inv_cancel hr, mul_one],
end

end comphaus_filtered_pseudo_normed_group_hom

open CompHausFiltPseuNormGrp₁

def strictify_nat_trans {C : Type*} [category C] {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  F ⋙ CompHausFiltPseuNormGrp₁.rescale.{u u} c ⟶ G :=
{ app := λ X, comphaus_filtered_pseudo_normed_group_hom.strictify _ _ (α.app X) c (h X),
  naturality' := λ X Y f, begin
    ext x, have := α.naturality f, apply_fun (λ φ, φ.to_fun x) at this, exact this
  end }

lemma strictify_nat_trans_enlarging {C : Type*} [category C]
  {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  whisker_right (strictify_nat_trans α c h) CHFPNG₁_to_CHFPNGₑₗ =
  (functor.associator _ _ _).hom ≫ whisker_left F (rescale_enlarging_iso c).hom ≫ α :=
begin
  ext, refl,
end

@[simp]
lemma strictify_nat_trans_enlarging' {C : Type*} [category C]
  {F G : C ⥤ CompHausFiltPseuNormGrp₁.{u}}
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u} ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u}) (c : ℝ≥0) [fact (0 < c)]
  (h : ∀ X, (α.app X).bound_by c) :
  whisker_left F (rescale_enlarging_iso.{u u} c).inv ≫ (functor.associator _ _ _).inv ≫
  whisker_right (strictify_nat_trans α c h) CHFPNG₁_to_CHFPNGₑₗ = α :=
begin
  ext, refl,
end

-- move me
instance preadditive_CompHausFiltPseuNormGrp : preadditive CompHausFiltPseuNormGrp.{u} :=
{ hom_group := λ M N, by apply_instance,
  add_comp' := by { intros X Y Z f₁ f₂ g, ext, exact g.map_add _ _ },
  comp_add' := by { intros, ext, refl } }

section

variables {F G H : Fintype.{u} ⥤ CompHausFiltPseuNormGrp₁.{u}}
variables (α β : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
variables (c cα cβ cαβ : ℝ≥0) [fact (0 < c)] [fact (0 < cα)] [fact (0 < cβ)] [fact (0 < cαβ)]

def nonstrict_extend (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (c : ℝ≥0) [fact (0 < c)] (h : ∀ X, (α.app X).bound_by c) :
  Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend.{u} G ⋙ CHFPNG₁_to_CHFPNGₑₗ :=
whisker_left (Profinite.extend F) (rescale_enlarging_iso.{u u} c).inv ≫
whisker_right ((Profinite.extend_commutes _ _).hom ≫
  Profinite.extend_nat_trans.{u} (strictify_nat_trans α c h)) CHFPNG₁_to_CHFPNGₑₗ

-- move me
attribute [reassoc] whisker_left_comp whisker_right_comp

lemma nonstrict_extend_whisker_left (h : ∀ X, (α.app X).bound_by c) :
  whisker_left Fintype.to_Profinite (nonstrict_extend.{u} α c h) =
  (functor.associator _ _ _).inv ≫
  whisker_right (Profinite.extend_extends.{u} F).hom CHFPNG₁_to_CHFPNGₑₗ.{u} ≫ α ≫
  whisker_right (Profinite.extend_extends.{u} G).inv CHFPNG₁_to_CHFPNGₑₗ.{u} ≫
  (functor.associator _ _ _).hom :=
begin
  rw [nonstrict_extend, whisker_right_comp, whisker_left_comp, whisker_left_comp,
    ← whisker_right_left, ← whisker_right_left, Profinite.extend_nat_trans_whisker_left,
    whisker_right_comp, whisker_right_comp, strictify_nat_trans_enlarging,
    ← category_theory.whisker_right_comp_assoc, Profinite.extend_commutes_comp_extend_extends],
  refl,
end
.

lemma nonstrict_extend_bound_by (h : ∀ X, (α.app X).bound_by c) (X : Profinite.{u}) :
  ((nonstrict_extend α c h).app X).bound_by c :=
begin
  conv begin congr, skip, rw ← one_mul c, end, -- can't get nth_rewrite to work
  refine comphaus_filtered_pseudo_normed_group_hom.bound_by.comp (λ r m hm, _) _,
  { rw mul_comm,
    rwa (show r = r * c * c⁻¹, begin
      rw [mul_assoc, mul_inv_cancel (ne_of_gt (fact.elim infer_instance)), mul_one];
      apply_instance,
    end) at hm },
  { rw [← one_mul (1 : ℝ≥0), whisker_right_comp],
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one },
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one } },
end

lemma nonstrict_extend_ext'
  (α β : Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (c : ℝ≥0) [fact (0 < c)] (hα : ∀ X, (α.app X).bound_by c) (hβ : ∀ X, (β.app X).bound_by c)
  (h : whisker_left Fintype.to_Profinite α = whisker_left Fintype.to_Profinite β) :
  α = β :=
begin
  suffices : strictify_nat_trans α c hα = strictify_nat_trans β c hβ,
  { rw [← strictify_nat_trans_enlarging' α c hα, ← strictify_nat_trans_enlarging' β c hβ, this] },
  rw ← cancel_epi (Profinite.extend_commutes F (CompHausFiltPseuNormGrp₁.rescale.{u u} c)).inv,
  apply Profinite.extend_nat_trans_ext,
  simp only [whisker_left_comp, cancel_epi],
  refine ((whiskering_right _ _ _).obj CHFPNG₁_to_CHFPNGₑₗ.{u}).map_injective _,
  simp only [whiskering_right_obj_map, whisker_right_left,
    strictify_nat_trans_enlarging, whisker_left_comp, h],
end

-- move me
instance fact_max_pos : fact (0 < max cα cβ) := ⟨lt_max_iff.mpr (or.inl $ fact.out _)⟩

lemma nonstrict_extend_mono (c₁ c₂ : ℝ≥0) [fact (0 < c₁)] [fact (0 < c₂)]
  (h₁ : ∀ X, (α.app X).bound_by c₁) (h₂ : ∀ X, (α.app X).bound_by c₂) :
  nonstrict_extend α c₁ h₁ = nonstrict_extend α c₂ h₂ :=
begin
  refine nonstrict_extend_ext' _ _ (max c₁ c₂) _ _ _,
  { intro X, refine (nonstrict_extend_bound_by _ _ _ _).mono _ (le_max_left _ _), },
  { intro X, refine (nonstrict_extend_bound_by _ _ _ _).mono _ (le_max_right _ _), },
  { simp only [nonstrict_extend_whisker_left], }
end

lemma nonstrict_extend_ext
  (α β : Profinite.extend.{u} F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ Profinite.extend G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (cα : ℝ≥0) [fact (0 < cα)] (cβ : ℝ≥0) [fact (0 < cβ)]
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (h : whisker_left Fintype.to_Profinite α = whisker_left Fintype.to_Profinite β) :
  α = β :=
begin
  refine nonstrict_extend_ext' _ _ (max cα cβ) _ _ h,
  { intro X, refine (hα X).mono _ (le_max_left _ _), },
  { intro X, refine (hβ X).mono _ (le_max_right _ _), },
end

-- move me
instance fact_add_pos (c₁ c₂ : ℝ≥0) [h₁ : fact (0 < c₁)] [h₂ : fact (0 < c₂)] :
  fact (0 < c₁ + c₂) :=
⟨add_pos h₁.1 h₂.1⟩

lemma nonstrict_extend_map_add (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α + β).app X).bound_by cαβ) :
  nonstrict_extend (α + β) cαβ hαβ = nonstrict_extend α cα hα + nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα + cβ) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_add],
    exact (nonstrict_extend_bound_by _ _ _ X).add (nonstrict_extend_bound_by _ _ _ X), },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_add],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.add_comp, preadditive.comp_add,
      nat_trans.app_add, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_map_neg
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((-α).app X).bound_by cβ) :
  nonstrict_extend (-α) cβ hβ = -nonstrict_extend α cα hα :=
begin
  refine nonstrict_extend_ext _ _ cβ cα _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X, apply (nonstrict_extend_bound_by _ _ _ _).neg, },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_neg],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.neg_comp, preadditive.comp_neg,
      nat_trans.app_neg, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_map_sub (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α - β).app X).bound_by cαβ) :
  nonstrict_extend (α - β) cαβ hαβ = nonstrict_extend α cα hα - nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα + cβ) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_sub],
    exact (nonstrict_extend_bound_by _ _ _ X).sub (nonstrict_extend_bound_by _ _ _ X), },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_sub],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.sub_comp, preadditive.comp_sub,
      nat_trans.app_sub, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], },
end

lemma nonstrict_extend_map_nsmul (n : ℕ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, ((n • α).app X).bound_by cβ) :
  nonstrict_extend (n • α) cβ hβ = n • nonstrict_extend α cα hα :=
begin
  refine nonstrict_extend_ext _ _ cβ (1 + n * cα) _ _ _,
  { intro X, apply nonstrict_extend_bound_by, },
  { intro X,
    simp only [nat_trans.app_nsmul],
    exact ((nonstrict_extend_bound_by _ _ _ _).nsmul _).mono _ le_add_self, },
  { ext S : 2,
    simp only [whisker_left_app, nat_trans.app_nsmul],
    simp only [← whisker_left_app, nonstrict_extend_whisker_left,
      nonstrict_extend_whisker_left, preadditive.nsmul_comp, preadditive.comp_nsmul,
      nat_trans.app_nsmul, nat_trans.comp_app, category.id_comp, category.comp_id,
      functor.associator_hom_app, functor.associator_inv_app], }
end

lemma nonstrict_extend_comp
  (α : F ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ G ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (β : G ⋙ CHFPNG₁_to_CHFPNGₑₗ ⟶ H ⋙ CHFPNG₁_to_CHFPNGₑₗ)
  (hα : ∀ X, (α.app X).bound_by cα) (hβ : ∀ X, (β.app X).bound_by cβ)
  (hαβ : ∀ X, ((α ≫ β).app X).bound_by cαβ) :
  nonstrict_extend (α ≫ β) cαβ hαβ = nonstrict_extend α cα hα ≫ nonstrict_extend β cβ hβ :=
begin
  refine nonstrict_extend_ext _ _ cαβ (cα * cβ) (nonstrict_extend_bound_by _ _ _) _ _,
  { intro X,
    rw mul_comm,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { exact nonstrict_extend_bound_by α cα hα X },
    { exact nonstrict_extend_bound_by β cβ hβ X } },
  { simp only [nonstrict_extend_whisker_left, whisker_left_comp, category.assoc,
      ← iso_whisker_right_hom, ← iso_whisker_right_inv,
      iso.hom_inv_id_assoc, iso.inv_hom_id_assoc], }
end

lemma nonstrict_extend_id
  (hα : ∀ X, (nat_trans.app (𝟙 (F ⋙ CHFPNG₁_to_CHFPNGₑₗ.{u})) X).bound_by cα) :
  nonstrict_extend (𝟙 _) cα hα = 𝟙 _ :=
begin
  refine nonstrict_extend_ext _ _ cα 1 (nonstrict_extend_bound_by _ _ _) _ _,
  { intro X, exact comphaus_filtered_pseudo_normed_group_hom.mk_of_bound_bound_by _ _ _ },
  { simp only [nonstrict_extend_whisker_left, whisker_left_comp, category.assoc,
      ← iso_whisker_right_hom, ← iso_whisker_right_inv, category.id_comp,
      iso.hom_inv_id_assoc, iso.inv_hom_id_assoc, whisker_left_id'],
    refl, }
end

lemma nonstrict_extend_whisker_right_enlarging (α : F ⟶ G) :
  nonstrict_extend (whisker_right α CHFPNG₁_to_CHFPNGₑₗ) 1
    (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one) =
  whisker_right (Profinite.extend_nat_trans α) _ :=
begin
  refine nonstrict_extend_ext _ _ 1 1 (nonstrict_extend_bound_by _ _ _)
    (λ X, (comphaus_filtered_pseudo_normed_group_hom.mk_of_strict_strict _ _).bound_by_one) _,
  rw [nonstrict_extend_whisker_left, ← whisker_right_left, Profinite.extend_nat_trans_whisker_left],
  refl
end

end