import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem two_colorable_bipartite {G : Type*} [graph G] : 2-colorable G ↔ bipartite G :=
begin
  have h0 : 2-colorable G → ∃ (V1 V2 : set G),
      valid_coloring V1 red ∧ valid_coloring V2 blue ∧
      ∀ (x y : G), x ≠ y → connected x y → ((x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1)),
    assume hcolor,
    by {cases hcolor.2.2 with V1 hV1, cases hcolor.2.1 with V2 hV2, use [V1,V2], split,
      exact hV1, split, exact hV2, assume x y hxy hconn,
      cases hcolor.1 hxy with hcxy hcyx, cases hcxy with hcx hcx',
      cases hcx.1, cases hcyx.1,
      have hconn2 : connected y x, from @connected_comm G (x y) _ _ hconn,
      have hconnxy : connected x y, from @connected_symm G (x y) _ _ hconn,
      have hconnyx : connected y x, from @connected_symm G (y x) _ _ hconn2,
      cases hcyx.2 with hry hrx, rw hry at hcx,
      have hx : x ∈ V2, from @color_member G (x) _ (blue) (hcx) (hconnxy),
      cases hcx'.1, cases hcxy.1,
      cases hcxy.2 with hrx hrx', rw hrx' at hcyx,
      have hy : y ∈ V2, from @color_member G (y) _ (blue) (hcyx) (hconnyx),
      show (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1), from or.inr ⟨hx,hy⟩,
      cases hcx'.2 with hry hrx',
      have hx : x ∈ V2, from @color_member G (x) _ (blue) (hcx') (hconnxy),
      cases hcyx.2 with hry hrx, rw hrx at hcx,
      have hy : y ∈ V1, from @color_member G (y) _ (red) (hcx) (hconnyx),
      show (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1), from or.inr ⟨hx,hy⟩,
      cases hcx.2 with hry hrx, rw hry at hcx',
      have hx : x ∈ V1, from @color_member G (x) _ (red) (hcx') (hconnxy),
      cases hcyx.2 with hry hrx', rw hrx' at hcx',
      have hy : y ∈ V1, from @color_member G (y) _ (red) (hcyx) (hconnyx),
      show (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1), from or.inl ⟨hx,hy⟩,
      cases hcx'.2 with hry hrx',
      have hx : x ∈ V1, from @color_member G (x) _ (red) (hcx') (hconnxy),
      cases hcyx.2 with hry hrx', rw hry at hcx,
      have hy : y ∈ V1, from @color_member G (y) _ (red) (hcyx) (hconnyx),
      show (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1), from or.inl ⟨hx,hy⟩,},

  have h1 : bipartite G → 2-colorable G,
    assume hbipart,
    by {cases h0 hbipart with V1 hV1, cases hV1 with V2 hV2,
      cases hV2 with hV1red hV2, cases hV2 with hV2blue hV2,
      use (V1, V2), split, from hV1blue,
      split, from hV1red,
      from hV2},

  split, from h1, from h0
end

--OUTPUT 2
theorem two_colorable_iff_bipartite {G : Type*} [graph G] : (∃ (A B : set G), is_valid_coloring A B) ↔ is_bipartite G :=
begin
    split,
    { assume h, by {
        cases h with A h,
        cases h with B h,
        have h1: is_valid_coloring A B, from h,
        have h2: ∀ v e, v ∈ A ∧ v = head e → tail e ∉ A,
          assume v e hv, assume h,
          apply h1 v e hv (and.intro h (and.intro rfl rfl)),
        have h3: ∀ v e, v ∈ B ∧ v = tail e → head e ∉ B,
          assume v e hv, assume h,
          apply h1 v e (and.intro h (and.intro rfl rfl)) hv,
        have h4: ∀ v e, v ∈ A ∧ v = tail e → head e ∉ A,
          assume v e hv, assume h,
          have h5: head e = tail e, from calc
            head e = v : and.left hv
            ... = tail e : (and.right hv).left
            ... = head e : (and.right hv).right,
          have h6: v = head e, from calc
            v = head e : h5
            ... = v : and.left hv,
          have h7: v ∈ B, from h3 v e (and.intro h6 (and.intro rfl rfl)) h,
          have h8: head e ∈ A, from h2 v e (and.intro h6 (and.intro rfl rfl)) h7,
          show false, from absurd h (and.intro h8 (and.intro rfl rfl)),
        have h5: ∀ v e, v ∈ B ∧ v = head e → tail e ∉ B,
          assume v e hv, assume h,
          have h6: head e = tail e, from calc
            head e = v : and.left hv
            ... = tail e : (and.right hv).left
            ... = head e : (and.right hv).right,
          have h7: v = tail e, from calc
            v = tail e : h6
            ... = v : and.left hv,
          have h8: v ∈ A, from h2 v e (and.intro h7 (and.intro rfl rfl)) h,
          have h9: tail e ∈ B, from h3 v e (and.intro h7 (and.intro rfl rfl)) h8,
          show false, from absurd h (and.intro h9 (and.intro rfl rfl)),
        have h6: ∀ v e, v ∈ A ∧ v = head e → tail e ∈ B,
          assume v e hv, assume h,
          have h7: head e ∉ B, from h5 v e hv h,
          have h8: tail e ∈ A, from h2 v e hv h,
          have h9: tail e ∉ A, from h4 v e (and.intro h8 (and.intro rfl rfl)) h,
          show tail e ∈ B, from or.cases_on (set.mem_or_mem_of_ne h9 h7)
            (λ h10, absurd h10 h7) (λ h11, h11),
        have h7: ∀ v e, v ∈ B ∧ v = tail e → head e ∈ A,
          assume v e hv, assume h,
          have h8: tail e ∉ A, from h4 v e hv h,
          have h9: head e ∈ B, from h3 v e hv h,
          have h10: head e ∉ B, from h5 v e (and.intro h9 (and.intro rfl rfl)) h,
          show head e ∈ A, from or.cases_on (set.mem_or_mem_of_ne h10 h8)
            (λ h11, absurd h11 h8) (λ h12, h12),
        show is_bipartite G, from is_bipartite.mk A B h6 h7,
        },
    { assume h, by {
        cases h with A B h,
        cases h with h3 h4,
        use A,
        use B,
        assume v e hv,
        assume h,
        have h5: v ∈ A ∨ v ∈ B, from set.mem_or_mem_of_ne hv.right,
        have h6: v ∈ A ∧ v = head e, from or.cases_on h5
          (λ h5a, and.intro h5a
            (calc
              v = head e : hv.left
              ... = v : h5a
            )
          )
          (λ h5b, and.intro h5b
            (calc
              head e = v : hv.left
              ... = tail e : (and.right hv).left
              ... = head e : (and.right hv).right
            )
          ),
        have h7: v ∈ B ∧ v = tail e, from or.cases_on h5
          (λ h5a, and.intro h5a
            (calc
              head e = v : hv.left
              ... = tail e : (and.right hv).left
              ... = head e : (and.right hv).right
            )
          )
          (λ h5b, and.intro h5b
            (calc
              v = tail e : hv.left
              ... = v : h5b
            )
          ),
        or.cases_on (set.mem_or_mem_of_ne h)
          (λ h8, absurd (h4 v e h7 h8) h8)
          (λ h9, absurd (h3 v e h6 h9) h9),
        },
    },
end

--OUTPUT 3
theorem is_bipartite_iff {α : Type*} (G : graph α) : is_bipartite G ↔ is_two_colorable G :=
begin
  split,
  { --Suppose $G$ is bipartite.
    assume hbip : is_bipartite G,
    use (λ x, by {
      apply by_cases,
      { --Suppose $x \in V_{1}$.
        assume hV1 : x ∈ G.V_1,
        exact (1 : ℕ), },
      { --Suppose $x \in V_{2}$.
        assume hV2 : x ∉ G.V_1,
        have hV2' : x ∈ G.V_2, from @is_bipartite.in_V_2 _ G hbip hV2,
        exact (2 : ℕ), },
    }),
    assume a b,
    apply by_cases,
    {
      assume haV1 : a ∈ G.V_1,
      apply by_cases,
      {
        assume hbV1 : b ∈ G.V_1,
        have h : _ := @is_bipartite.V_1_V_2_disjoint _ G hbip haV1 hbV1,
        rw h, },
      {
        assume hbV2 : b ∉ G.V_1,
        have hbV2' : _ := @is_bipartite.in_V_2 _ G hbip hbV2,
        have h : _ := @is_bipartite.no_edge_V_1_V_2 _ G hbip haV1 hbV2',
        rw h,
        show (1 : ℕ) ≠ (2 : ℕ), from assume hne, by {
          rw hne at hbV2,
          contradiction, }, }, },
    {
      assume haV2 : a ∉ G.V_1,
      apply by_cases,
      {
        assume hbV1 : b ∈ G.V_1,
        have hbV1' : b ∈ G.V_2, from @is_bipartite.in_V_1 _ G hbip hbV1,
        have h : _ := @is_bipartite.no_edge_V_1_V_2 _ G hbip hbV1' haV2,
        rw h,
        show (2 : ℕ) ≠ (1 : ℕ), from assume hne, by {
          rw hne at haV2,
          contradiction, }, },
      {
        assume hbV2 : b ∈ G.V_2,
        have h : _ := @is_bipartite.V_1_V_2_disjoint _ G hbip hbV2 haV2,
        rw h, }, }, },
  { --Suppose that $G$ is two-colourable.
    assume hcol : is_two_colorable G,
    let V_1 := {a : α | hcol.coloring a = (1 : ℕ)},
    let V_2 := {a : α | hcol.coloring a = (2 : ℕ)},
    have hV_1_V_2_disjoint : ∀ a : α, a ∈ V_1 ∧ a ∈ V_2 → false, from
      assume a : α, assume haV1V2 : a ∈ V_1 ∧ a ∈ V_2, by {
        have hV1 : hcol.coloring a = (1 : ℕ), from haV1V2.left,
        have hV2 : hcol.coloring a = (2 : ℕ), from haV1V2.right,
        have h : (1 : ℕ) = (2 : ℕ), from congr_arg hcol.coloring hV1,
        rw h at hV2,
        contradiction,
    },
    have hno_edge_V_1_V_2 : ∀ a b : α, edge_between G a b ∧ a ∈ V_1 ∧ b ∈ V_2 → false, from
      assume a b : α, assume habV_1V_2 : edge_between G a b ∧ a ∈ V_1 ∧ b ∈ V_2, by {
        have hV1 : hcol.coloring a = (1 : ℕ), from habV_1V_2.right.left,
        have hV2 : hcol.coloring b = (2 : ℕ), from habV_1V_2.right.right,
        have he : hcol.coloring a ≠ hcol.coloring b, from habV_1V_2.left,
        have h : (1 : ℕ) ≠ (2 : ℕ), from congr_arg hcol.coloring he,
        rw hV1 at h,
        rw hV2 at h,
        contradiction,
    },
    show is_bipartite G, from ⟨V_1, V_2, hV_1_V_2_disjoint, hno_edge_V_1_V_2⟩,
  },
end

--OUTPUT 4
theorem by_perez_graph_bipartite_iff_twocolorable (G : Type*) [simple_graph G] :
  bipartite G ↔ twocolorable G :=
begin
  show bipartite G → twocolorable G, from by {
    assume h : bipartite G,

    have
  },
  show twocolorable G → bipartite G, from by {obviously},
end

--OUTPUT 5
theorem two_colorable_bipartite {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  show two_colorable G ↔ bipartite G,
    split,
    intro hcolorable,
    unfold two_colorable at hcolorable,
    cases two_colorable.elim hcolorable with A hA,
    cases two_colorable.elim hcolorable with B hB,
    show bipartite G, from by
    refine ⟨A,B,λ (x : G) (y : G) (hconnected : connected G x y), _⟩,
    have h1 : ∃ (v1 v2 : G), v1 ∈ A ∧ v2 ∈ B ∧ v1 ≠ v2 ∧ connected G v1 v2, from two_colorable.elim hcolorable,
    cases h1 with v1 h1,
    cases h1 with v2 h1,
    cases h1 with hv1 h1,
    cases h1 with hv2 h1,
    cases h1 with hdifferent hconnected,
    have hconnected' : connected G v1 v2 ∧ connected G v2 v1, from by {
      split,
      show connected G v1 v2, from by apply hconnected,
      show connected G v2 v1, from by {apply connected_symm,exact hconnected}
    },
    rw ← hA v1 at hv1,
    rw ← hB v2 at hv2,
    show h1.left, from by {
      cases hconnected' with hconnected1 hconnected2,
      have h2 : v1 = v2, from by
      apply two_colorable.elim(hcolorable) v1 v2 h1.right.right h1.right.left hconnected1 hconnected2 hv1 hv2,
      rw (mt hdifferent h2),
      apply h1.right,
    },
    intro hbipartite,
    cases hbipartite with V1 hbipartite,
    cases hbipartite with V2 hbipartite,
    have hunion : disjoint V1 V2 ∧ V1 ∪ V2 = G, from by {
      split,
      from hbipartite.left,
      from hbipartite.right,
    },
    have h1 : (V1 ∪ V2) × G ⊆ V1 × V2 ∨ (V1 ∪ V2) × G ⊆ V2 × V1, from by
    refine or.elim (hbipartite.right.elim _ _) _,
    cases h1,
      have h2 : (V1 ∪ V2) × G ⊆ V1 × V2, from by {
        apply h1,
      },
    have h3 : (V1 ∪ V2) × G ⊆ V2 × V1, from by {
      apply h1,
    },
    have color : (V1 ∪ V2) × G → 2, from
    assume (x y : G), if h : (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1) then 0 else 1,
    have h4 : ∀ (x y z w : G), connected G x y → connected G z w → (color (x,z) = color (y,w)), from
    assume (x y z w : G) (hconnected1 : connected G x y) (hconnected2 : connected G z w),
           if h : (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1) then
              if h' : (z ∈ V1 ∧ w ∈ V2) ∨ (z ∈ V2 ∧ w ∈ V1) then 0 else 1
           else 1,
    have h5 : ∀ (x y : G), (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1) → connected G x y, from
    assume (x y : G) (h1 : (x ∈ V1 ∧ y ∈ V2) ∨ (x ∈ V2 ∧ y ∈ V1)),
           if h : x ∈ V1 ∧ y ∈ V2 then hbipartite.right (x,y)
           else if h' : x ∈ V2 ∧ y ∈ V1 then hbipartite.right (y,x)
           else false.elim (mt h1 ⟨h,h'⟩),
    show two_colorable G, from ⟨V1∪V2, color, h2, h3, h4, h5⟩,
end

--OUTPUT 6
theorem bipartite_2_colorable (G : Type*) [simple_graph G] :
  is_bipartite G ↔ is_two_colorable G :=
begin
  simp [is_two_colorable],
  apply iff_of_eq,
  split;
  assume h1 h2;
  have h3 : ∃ (A : set G.V) (B : set G.V), h2 = ⟨A, B⟩, from by {exact h2.2},
  rcases h3 with ⟨A, B, h3⟩,
  rw h3,
  have h4 : ∀ (v : G.V), v ∈ A ∨ v ∈ B, from λ v, by {rw h3, exact h2.1.2 v},
  have h5 : ∀ (u : G.V) (v : G.V), G.E v u → (u ∈ A → v ∈ B) ∧ (u ∈ B → v ∈ A), from by {
    assume (u : G.V) (v : G.V) (h_edge : G.E v u);
    simp [h1.2] at h_edge,
    show (u ∈ A → v ∈ B) ∧ (u ∈ B → v ∈ A), from by {split,
      assume h_u_A : (u ∈ A), have h_v_B : v ∈ B, from by {
        rw h_edge,
        exact h2.1.1 v,
        exact h_u_A,
      }, exact h_v_B,
      assume h_u_B : u ∈ B, have h_v_A : v ∈ A, from by {
        rw h_edge,
        exact h2.1.1 v,
        exact h_u_B,
      }, exact h_v_A,
    },
  },
  have h6 : ∀ (v : G.V), v ∉ G.E.range, from λ (v : G.V),
    assume h_v_range : v ∈ G.E.range,
    by {have h_dom : v ∈ G.E.domain, from by {exact G.E.has_mem_range.1 h_v_range},
      rw h1.2 at h_dom,
      contradiction},
  have h7 : ∀ (v : G.V), ∀ (u : G.V), G.E v u → (v ∉ A ∧ u ∈ B) ∨ (v ∈ A ∧ u ∉ B), from by {
    assume (v : G.V) (u : G.V) (h_edge : G.E v u),
    assume h_v_A : (v ∈ A),
    assume h_u_A : (u ∈ A),
    have h_v_range : v ∈ G.E.range, from by {
      have h_dom : u ∈ G.E.domain, from by {exact G.E.has_mem_domain.2 h_edge},
      exact G.E.has_mem_range.2 ⟨h_dom, h_v_A⟩
    },
    have h_u_range : u ∈ G.E.range, from by {
      have h_dom : v ∈ G.E.domain, from by {exact G.E.has_mem_domain.2 h_edge},
      exact G.E.has_mem_range.2 ⟨h_dom, h_u_A⟩
    },
    show (v ∉ A ∧ u ∈ B) ∨ (v ∈ A ∧ u ∉ B), from ii.elim h_u_A (by {
      assume h_u_A : (u ∉ A),
      show (v ∉ A ∧ u ∈ B) ∨ (v ∈ A ∧ u ∉ B), from or.inl ⟨h_v_range, h_u_A⟩
    }) (by {
      assume h_u_A : (u ∈ A),
      show (v ∉ A ∧ u ∈ B) ∨ (v ∈ A ∧ u ∉ B), from or.inr ⟨h_v_A, h_u_range⟩
    }),
  },

  have h8 : ∀ (v : G.V), v ∉ G.E.domain, from λ (v : G.V),
    assume h_v_domain : v ∈ G.E.domain,
    by {have h_range : v ∈ G.E.range, from by {exact G.E.has_mem_domain.1 h_v_domain},
      rw h1.2 at h_range,
      contradiction},

  have h9 : ∀ (u : G.V), ∀ (v : G.V), G.E u v → (u ∉ B ∧ v ∈ A) ∨ (u ∈ B ∧ v ∉ A), from by {
    assume (u : G.V) (v : G.V) (h_edge : G.E u v),
    have h_dom : u ∈ G.E.domain, from by {exact G.E.has_mem_domain.2 h_edge},
    have h_range : v ∈ G.E.range, from by {exact G.E.has_mem_range.2 ⟨h_dom, h2.1.1 v⟩},
    rw h1.2 at h_range,
    show (u ∉ B ∧ v ∈ A) ∨ (u ∈ B ∧ v ∉ A), from ii.elim h2.1.1 v (by {
      assume h_v_A : (v ∈ A),
      show (u ∉ B ∧ v ∈ A) ∨ (u ∈ B ∧ v ∉ A), from or.inr ⟨h_dom, h_v_A⟩
    }) (by {
      assume h_v_A : (v ∉ A),
      show (u ∉ B ∧ v ∈ A) ∨ (u ∈ B ∧ v ∉ A), from or.inl ⟨h_range, h_v_A⟩
    })
  },
  {split,
    show ∀ (v : G.V), v ∈ A ∨ v ∈ B, from h4,
    show ∀ (u v : G.V), G.E u v → (u ∈ A → v ∈ B) ∧ (u ∈ B → v ∈ A), from h5,
  },
  {split,
    show ∀ (v : G.V), v ∈ A ∨ v ∈ B, from h4,
    show ∀ (u v : G.V), G.E u v → (u ∈ A → v ∈ B) ∧ (u ∈ B → v ∈ A), from h9,
  },
end

--OUTPUT 7
theorem two_colorable_iff_bipartite {α : Type*} [fintype α] (G : graph α) : two_colorable G ↔ bipartite G :=
begin
  split,
    assume (h1 : two_colorable G),
    use (color_set h1 0),
    use (color_set h1 1),
    show ∀ e : α × α, e ∈ G.E → e.fst ∈ (color_set h1 0) ∧ e.snd ∈ (color_set h1 1), from
    begin
      assume (e : α × α) (he : e ∈ G.E),
      have h2 : (e.fst ∈ (color_set h1 0)) ∨ (e.fst ∈ (color_set h1 1)), from (color_def h1 e.fst e.fst e.snd he).left,
      have h3 : (e.snd ∈ (color_set h1 0)) ∨ (e.snd ∈ (color_set h1 1)), from (color_def h1 e.snd e.fst e.snd he).right,
      have h4 : (e.fst ∈ (color_set h1 0)) ∧ (e.snd ∈ (color_set h1 1)) ∨ (e.fst ∈ (color_set h1 1)) ∧ (e.snd ∈ (color_set h1 0)), from or.imp_or_distrib h2 h3,
      cases h4,
        assume h5 : (e.fst ∈ (color_set h1 0)) ∧ (e.snd ∈ (color_set h1 1)),
        show (e.fst ∈ (color_set h1 0)) ∧ (e.snd ∈ (color_set h1 1)), from h5,
      assume h5 : (e.fst ∈ (color_set h1 1)) ∧ (e.snd ∈ (color_set h1 0)),
      have h6 : (e.fst ∈ (color_set h1 0)) ∧ (e.snd ∈ (color_set h1 1)), from and.intro h5.right h5.left,
      show (e.fst ∈ (color_set h1 0)) ∧ (e.snd ∈ (color_set h1 1)), from h6,
    end,

    assume hbip : bipartite G,
    show two_colorable G, from two_colorable.mk hbip,
end

--OUTPUT 8
theorem bipartite_graph_two_colorable {G : Type*} [graph G] :
∀ (G : Type*) [graph G], (∀ A : set G, pairwise_disjoint A ∧ complete G A) → (∃! coloring : coloring G 2, ∀ u v ∈ G.E, coloring u ≠ coloring v) :=
begin
  assume (G : Type*) [graph G],
  assume hpartite : ∀ A : set G, pairwise_disjoint A ∧ complete G A,
  have h1 : ∃! A : set G, pairwise_disjoint A ∧ complete G A, from
    exists_unique_partition G,
  have h2 : ∃! A : set G, set.finite A, from exists_unique_finite A,
  have h3 : ∃! A : set G, ∃! B : set G, set.finite A ∧ set.finite B ∧ A ∪ B = G.V, from
    by {unfold exists_unique_finite,use A,use B,exact ⟨h2.1.1,h2.1.2,set.ext.2 (h2.1.3).symm⟩,use B,use A,exact ⟨h2.2.1,h2.2.2,set.ext.2 (h2.2.3).symm⟩},
  have h4 : ∃! A : set G, ∃! B : set G, set.finite A ∧ set.finite B ∧ A ∪ B = G.V ∧ pairwise_disjoint A ∧ pairwise_disjoint B ∧ complete G A ∧ complete G B, from
    by {use A,use B,unfold exists_unique_disjoint,unfold exists_unique_finite,use A,use B,exact ⟨h2.1.1,h2.1.2,set.ext.2 (h2.1.3).symm,⟨(hpartite A).1,(hpartite B).1⟩,⟨(hpartite A).2,(hpartite B).2⟩⟩,use B,use A,exact ⟨h2.2.1,h2.2.2,set.ext.2 (h2.2.3).symm,⟨(hpartite B).1,(hpartite A).1⟩,⟨(hpartite B).2,(hpartite A).2⟩⟩},
  have h5 : ∃! coloring : coloring G 2, ∀ u v ∈ G.E, coloring u ≠ coloring v, from
    by {
      have h6 : ∀ A B : set G, set.finite A ∧ set.finite B ∧ A ∪ B = G.V ∧ pairwise_disjoint A ∧ pairwise_disjoint B ∧ complete G A ∧ complete G B → ∃! coloring : coloring G 2, ∀ u v ∈ G.E, coloring u ≠ coloring v, from by {
        assume (A B : set G) (h : set.finite A ∧ set.finite B ∧ A ∪ B = G.V ∧ pairwise_disjoint A ∧ pairwise_disjoint B ∧ complete G A ∧ complete G B),
        set coloring := λ (v : G.V), if v ∈ A then 0 else 1,
        have h1 : ∀ u v : G.V, u ≠ v → coloring u ≠ coloring v, from by {
          assume (u v : G.V) (huv : u ≠ v),
          have h1 : u ∉ A ↔ v ∈ A, from set.finite.finite_inter_iff_ne_empty (A ∩ B) (h.1.1) (h.2.1) huv,
          have h2 : u ∉ B ↔ v ∈ B, from set.finite.finite_inter_iff_ne_empty (A ∩ B) (h.2.1) (h.1.1) huv,
          by_contradiction (assume h3 : coloring u = coloring v), rw h3 at h1, rw h3 at h2,
          show false, from if (u ∈ A) then h1.elim (h.4 huv.symm) else h2.elim (h.5 huv.symm),
        },
        have h2 : ∀ u v ∈ G.E, coloring u ≠ coloring v, from by {
          assume (u v : G.V) (huv : u ∈ G.E) (vuv : v ∈ G.E),
          by_contradiction (assume hne : coloring u = coloring v), rw hne at huv, rw hne at vuv,
          show false, from if (u ∈ A) then huv.elim (h.6 v vuv) else vuv.elim (h.7 u huv),
        },
        show ∃! coloring : coloring G 2, ∀ u v ∈ G.E, coloring u ≠ coloring v, from by {
          use coloring, unfold coloring.fst, unfold coloring.snd,
          have h1 : ∀ u v : G.V, u ∈ A → v ∈ A → u ≠ v → u = v, from by {
            assume (u v : G.V) (huv : u ∈ A) (hvu : v ∈ A) (h3 : u ≠ v), rw ←h3 at huv, exact huv,
          },
          have h2 : ∀ u v : G.V, u ∈ B → v ∈ B → u ≠ v → u = v, from by {
            assume (u v : G.V) (huv : u ∈ B) (hvu : v ∈ B) (h3 : u ≠ v), rw ←h3 at hvu, exact hvu,
          },
          have h3 : ∀ u v : G.V, u ≠ v → coloring u ≠ coloring v, from by {
            assume (u v : G.V) (huv : u ≠ v),
            have h1 : u ∉ A ↔ v ∈ A, from set.finite.finite_inter_iff_ne_empty (A ∩ B) (h.1.1) (h.2.1) huv,
            have h2 : u ∉ B ↔ v ∈ B, from set.finite.finite_inter_iff_ne_empty (A ∩ B) (h.2.1) (h.1.1) huv,
            by_contradiction (assume h3 : coloring u = coloring v), rw h3 at h1, rw h3 at h2,
            show false, from if (u ∈ A) then h1.elim (h.4 huv.symm) else h2.elim (h.5 huv.symm),
          },
          exact ⟨h1,h2,h3⟩
        },
      },
      have h7 : ∀ A B : set G, A ∪ B = G.V ∧ pairwise_disjoint A ∧ pairwise_disjoint B ∧ complete G A ∧ complete G B → ∃! coloring : coloring G 2, ∀ u v ∈ G.E, coloring u ≠ coloring v, from by {
        assume (A B : set G) (h : A ∪ B = G.V ∧ pairwise_disjoint A ∧ pairwise_disjoint B ∧ complete G A ∧ complete G B),
        show ∃! coloring : coloring G 2, ∀ u v ∈ G.E, coloring u ≠ coloring v, from by {
          have h1 : A = (A ∩ B) ∪ (A \ B), from set.ext.2 (by {
            rw [set.inter_comm,set.union_inter_cancel_left], unfold set.inter_eq, rw h.1.1, unfold set.sUnion,
          }),
          have h2 : A ∩ B = ∅, from (h.2.2 0 0 h.2.1 (set.not_mem_empty 0
end --Needs more than 2000 tokens!

--OUTPUT 9
theorem bipartite_iff_two_colorable {G : Type*} [graph G] : bipartite G ↔ ∃ (V1 V2 : set (vertex G)), is_coloring G {c | c = red ∨ c = blue} V1 V1.compl V2 V2.compl :=
begin
  split,
  exact @bipartite_two_colorable G _,
  exact @two_colorable_bipartite G _,
end

--OUTPUT 10
theorem bipartite_2_colorable (G : Type*) [graph G] :
  ∀ V₁ V₂ : G, (∀ v₁ v₂ : V₁, ¬v₁.adj v₂) ∧ (∀ v₁ v₂ : V₂, ¬v₁.adj v₂) ∧
  (∀ v₁ ∈ V₁, ∃ v₂ ∈ V₂, v₁.adj v₂) ∧ (∀ v₂ ∈ V₂, ∃ v₁ ∈ V₁, v₁.adj v₂)
    ↔ bipartite (exists_colorable_of_two_colorable G) :=
begin
  assume (V₁ V₂ : G),
  have h1 : ∀ v₁ v₂ : V₁, ¬v₁.adj v₂ ↔ v₁.color ≠ v₂.color, from assume v₁ v₂,
    by {
      have h2 : ∀ a b : G, a.color ≠ b.color → ¬a.adj b, from by {
        assume (a : G) (b : G),
        assume (h : a.color ≠ b.color) (h' : a.adj b),
        have h3 : a.color = b.color, from by {rw ←color_color G, exact two_colorable.both_colors a b h'},
        contradiction,
      },
      assume h : v₁.adj v₂,
      have h2 : v₁.color = v₂.color, from by {have h3 : v₁.adj v₂ ∧ v₂.adj v₁, from by {split,exact h, exact h},exact two_colorable.both_colors _ _ h3},
      have h3 : ¬v₁.color = v₂.color, from by {rw ←color_color G, exact two_colorable.both_colors _ _ h},
      have h4 : v₁.color ≠ v₂.color, from by {contradiction,},
      show ¬v₁.adj v₂, from h2 h4,
      show v₁.color ≠ v₂.color, from by {rw ←color_color G, exact two_colorable.both_colors _ _ h},
    },
have h2 : ∀ v₁ v₂ : V₂, ¬v₁.adj v₂ ↔ v₁.color ≠ v₂.color, from assume v₁ v₂,
    by {
      have h1 : ∀ a b : G, a.color ≠ b.color → ¬a.adj b, from by {
        assume (a : G) (b : G),
        assume (h : a.color ≠ b.color) (h' : a.adj b),
        have h3 : a.color = b.color, from by {rw ←color_color G, exact two_colorable.both_colors a b h'},
        contradiction,
      },
      assume h : v₁.adj v₂,
      have h2 : v₁.color = v₂.color, from by {have h3 : v₁.adj v₂ ∧ v₂.adj v₁, from by {split,exact h, exact h},exact two_colorable.both_colors _ _ h3},
      have h3 : ¬v₁.color = v₂.color, from by {rw ←color_color G, exact two_colorable.both_colors _ _ h},
      have h4 : v₁.color ≠ v₂.color, from by {contradiction,},
      show ¬v₁.adj v₂, from h2 h4,
      show v₁.color ≠ v₂.color, from by {rw ←color_color G, exact two_colorable.both_colors _ _ h},
    },
  have h3 : (∀ v₁ v₂ : V₁, ¬v₁.adj v₂) ∧ (∀ v₁ v₂ : V₂, ¬v₁.adj v₂) ↔ ∀ a b ∈ V₁, a.color ≠ b.color ∧ ∀ a b ∈ V₂, a.color ≠ b.color, from
    by {split;
    assume (h : (∀ v₁ v₂ : V₁, ¬v₁.adj v₂) ∧ (∀ v₁ v₂ : V₂, ¬v₁.adj v₂)),
    show ∀ a b ∈ V₁, a.color ≠ b.color ∧ ∀ a b ∈ V₂, a.color ≠ b.color, from
    by {
      split;
      assume a b,
      assume (h1 : a ∈ V₁) (h2 : b ∈ V₁),
      show a.color ≠ b.color, from h.left a b,
      assume a b,
      assume (h1 : a ∈ V₂) (h2 : b ∈ V₂),
      show a.color ≠ b.color, from h.right a b,
    },
    assume (h : ∀ a b ∈ V₁, a.color ≠ b.color ∧ ∀ a b ∈ V₂, a.color ≠ b.color),
    show (∀ v₁ v₂ : V₁, ¬v₁.adj v₂) ∧ (∀ v₁ v₂ : V₂, ¬v₁.adj v₂), from
    by {
      split;
      assume v₁ v₂,
      show ¬v₁.adj v₂, from by {
        have h1 : ∀ a b, a.color ≠ b.color → ¬a.adj b, from by {
          assume (a : G) (b : G),
          assume (h : a.color ≠ b.color) (h' : a.adj b),
          have h3 : a.color = b.color, from by {rw ←color_color G, exact two_colorable.both_colors a b h'},
          contradiction,
        },
        assume h : v₁.adj v₂,
        have h2 : v₁.color = v₂.color, from by {have h3 : v₁.adj v₂ ∧ v₂.adj v₁, from by {split,exact h, exact h},exact two_colorable.both_colors _ _ h3},
        have h3 : ¬v₁.color = v₂.color, from by {rw ←color_color G, exact two_colorable.both_colors _ _ h},
        have h4 : v₁.color ≠ v₂.color, from by {contradiction,},
        show ¬v₁.adj v₂, from h2 h4,
      },
      assume v₁ v₂,
      show ¬v₁.adj v₂, from by {
        have h1 : ∀ a b, a.color ≠ b.color → ¬a.adj b, from by {
          assume (a : G) (b : G),
          assume (h : a.color ≠ b.color) (h' : a.adj b),
          have h3 : a.color = b.color, from by {rw ←color_color G, exact two_colorable.both_colors a b
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import analysis.normed_space.continuous_affine_map
import analysis.calculus.times_cont_diff

/-!
# Smooth affine maps

This file contains results about smoothness of affine maps.

## Main definitions:

 * `continuous_affine_map.times_cont_diff`: a continuous affine map is smooth

-/

namespace continuous_affine_map

variables {𝕜 V W : Type*} [nondiscrete_normed_field 𝕜]
variables [normed_group V] [normed_space 𝕜 V]
variables [normed_group W] [normed_space 𝕜 W]

/-- A continuous affine map between normed vector spaces is smooth. -/
lemma times_cont_diff {n : with_top ℕ} (f : V →A[𝕜] W) :
  times_cont_diff 𝕜 n f :=
begin
  rw f.decomp,
  apply f.cont_linear.times_cont_diff.add,
  simp only,
  exact times_cont_diff_const,
end

end continuous_affine_map


import order.lattice

set_option old_structure_cmd true

universe u

variable (α : Type u)

namespace zfc

class has_zmem extends has_mem α α

instance [has_zmem α] : has_subset α :=
⟨λ x y, ∀ z, z ∈ x → z ∈ y⟩

variable {α}

theorem subset.refl [has_zmem α] (x : α) : x ⊆ x := λ z, id
theorem subset.trans [has_zmem α] {x y z : α}
  (hxy : x ⊆ y) (hyz : y ⊆ z) : x ⊆ z :=
λ p hp, hyz p $ hxy p hp

instance [has_zmem α] : preorder α :=
⟨(⊆), _, subset.refl, λ x y z, subset.trans⟩

variable α

class is_extensional extends has_zmem α :=
(ext : ∀ x y : α, (∀ z, z ∈ x ↔ z ∈ y) → x = y )

variable {α}

theorem subset.antisymm [is_extensional α] {x y : α}
  (hxy : x ⊆ y) (hyx : y ⊆ x) : x = y :=
is_extensional.ext x y $ λ z, ⟨λ hx, hxy z hx, λ hy, hyx z hy⟩

instance partial_order [is_extensional α] : partial_order α :=
{ le_antisymm := λ x y, subset.antisymm,
  .. zfc.preorder }

variable α

class has_zempty extends has_zmem α, has_emptyc α :=
(not_zmem_empty : ∀ x, x ∉ (∅:α))

class has_upair extends has_zmem α :=
(upair : α → α → α)
(zmem_upair_iff_eq_or_eq : ∀ x y z, z ∈ upair x y ↔ z = x ∨ z = y)

variable {α}

theorem not_zmem_empty [has_zempty α] : ∀ {x}, x ∉ (∅:α) :=
has_zempty.not_zmem_empty

def upair [has_upair α] : α → α → α :=
has_upair.upair

def zmem_upair_iff_eq_or_eq [has_upair α] {x y z : α} :
z ∈ upair x y ↔ z = x ∨ z = y :=
has_upair.zmem_upair_iff_eq_or_eq x y z

theorem zmem_upair_left [has_upair α] {x y : α} : x ∈ upair x y :=
zmem_upair_iff_eq_or_eq.2 $ or.inl rfl

theorem zmem_upair_right [has_upair α] {x y : α} : y ∈ upair x y :=
zmem_upair_iff_eq_or_eq.2 $ or.inr rfl

def opair [has_upair α] (x y : α) : α :=
upair (upair x x) (upair x y)

theorem opair.ext [has_upair α] {p q r s : α}
  (h : opair p q = opair r s) : p = r ∧ q = s :=
begin
  have h1 : upair p p ∈ opair p q,
    from zmem_upair_left,
  have h2 : upair p q ∈ opair p q,
    from zmem_upair_right,
  have h3 : p ∈ upair p p,
    from zmem_upair_left,
  have h4 : p ∈ upair p q,
    from zmem_upair_left,
  have h5 : q ∈ upair p q,
    from zmem_upair_right,
  have h6 : upair r r ∈ opair r s,
    from zmem_upair_left,
  have h7 : upair r s ∈ opair r s,
    from zmem_upair_right,
  have h8 : r ∈ upair r r,
    from zmem_upair_left,
  have h9 : r ∈ upair r s,
    from zmem_upair_left,
  have h0 : s ∈ upair r s,
    from zmem_upair_right,
  rw h at h1 h2,
  rw ← h at h6 h7,
  unfold opair at h1 h2 h6 h7,
  rw zmem_upair_iff_eq_or_eq at h1 h2 h6 h7,
  cases h1,
  { rw [h1, zmem_upair_iff_eq_or_eq, or_self] at h3,
    subst h3,
    cases h2,
    { rw [h2, zmem_upair_iff_eq_or_eq, or_self] at h5,
      subst h5,
      rw or_self at h7,
      rw [h7, zmem_upair_iff_eq_or_eq, or_self] at h0,
      subst h0,
      split, refl, refl },
    { rw [h2, zmem_upair_iff_eq_or_eq] at h5,
      cases h5; subst h5,
      { rw [← h2, zmem_upair_iff_eq_or_eq, or_self] at h0,
        subst h0,
        split, refl, refl },
      { split, refl, refl } } },
  { rw [← h1, zmem_upair_iff_eq_or_eq, or_self] at h9,
    subst h9,
    rw [← h1, zmem_upair_iff_eq_or_eq, or_self] at h0,
    subst h0,
    rw or_self at h2,
    rw [h2, zmem_upair_iff_eq_or_eq, or_self] at h5,
    subst h5,
    split, refl, refl }
end

theorem opair.iff [has_upair α] {p q r s : α} : opair p q = opair r s ↔ p = r ∧ q = s :=
⟨opair.ext, λ ⟨hpq, hrs⟩, hpq ▸ hrs ▸ rfl⟩

variable α

class has_sUnion extends has_zmem α :=
(sUnion : α → α)
(zmem_sUnion_iff_zmem_zmem : ∀ x z, z ∈ sUnion x ↔ ∃ t, z ∈ t ∧ t ∈ x)

variable {α}

def sUnion [has_sUnion α] : α → α :=
has_sUnion.sUnion

def zmem_sUnion_iff_zmem_zmem [has_sUnion α] {x z : α} : z ∈ sUnion x ↔ ∃ t, z ∈ t ∧ t ∈ x :=
has_sUnion.zmem_sUnion_iff_zmem_zmem x z

variable α

class has_sUnion_upair extends has_sUnion α, has_upair α

instance [has_sUnion_upair α] : has_union α :=
⟨λ x y, sUnion $ upair x y⟩

instance [has_sUnion_upair α] : has_insert α α :=
⟨λ x A, upair x x ∪ A⟩

lemma union_def [has_sUnion_upair α] (x y : α) : x ∪ y = (sUnion $ upair x y) := rfl
lemma insert_def [has_sUnion_upair α] (x A : α) : has_insert.insert x A = upair x x ∪ A := rfl

variable {α}

lemma zmem_union_iff_zmem_or_zmem [has_sUnion_upair α] {x y z : α} : z ∈ x ∪ y ↔ z ∈ x ∨ z ∈ y :=
begin
  rw [union_def, zmem_sUnion_iff_zmem_zmem],
  split,
  { intro H,
    rcases H with ⟨t, H1, H2⟩,
    rw [zmem_upair_iff_eq_or_eq] at H2,
    cases H2; subst H2,
    { left, assumption },
    { right, assumption } },
  { intro H,
    cases H,
    { existsi x,
      split, exact H, exact zmem_upair_left },
    { existsi y,
      split, exact H, exact zmem_upair_right } }
end

lemma zmem_insert_iff_eq_or_zmem [has_sUnion_upair α] {x A z : α} : z ∈ has_insert.insert x A ↔ z = x ∨ z ∈ A :=
by rw [insert_def, zmem_union_iff_zmem_or_zmem, zmem_upair_iff_eq_or_eq, or_self]

theorem zmem_insert [has_sUnion_upair α] {x y : α} : x ∈ has_insert.insert x y :=
zmem_insert_iff_eq_or_zmem.2 $ or.inl rfl

theorem zmem_insert_of_zmem [has_sUnion_upair α] {x y z : α} (H : x ∈ z) : x ∈ has_insert.insert y z :=
zmem_insert_iff_eq_or_zmem.2 $ or.inr H

def succ [has_sUnion_upair α] : α → α :=
λ x, has_insert.insert x x

theorem zmem_succ_iff_eq_or_zmem [has_sUnion_upair α] {x y : α} : x ∈ succ y ↔ x = y ∨ x ∈ y :=
zmem_insert_iff_eq_or_zmem

theorem zmem_succ [has_sUnion_upair α] {x : α} : x ∈ succ x :=
zmem_succ_iff_eq_or_zmem.2 $ or.inl rfl

theorem zmem_succ_of_zmem [has_sUnion_upair α] {x y : α} (H : x ∈ y) : x ∈ succ y :=
zmem_succ_iff_eq_or_zmem.2 $ or.inr H

variable α

class has_powerset extends has_zmem α :=
(powerset : α → α)
(zmem_powerset : ∀ x z, z ∈ powerset x ↔ z ⊆ x)

class has_comprehension extends has_zmem α :=
(comprehension : α → (α → Prop) → α)
(zmem_comprehension_iff : ∀ A p x, x ∈ comprehension A p ↔ x ∈ A ∧ p x)

class has_infty :=
(infinity : α)

notation `∞` := has_infty.infinity _

class has_replacement extends has_zmem α :=
(replacement : α → (α → α → Prop) → α)
(zmem_replacement_iff : ∀ A (f : α → α → Prop) y (H : ∀ A B C, f A B → f A C → B = C), (y ∈ replacement A f ↔ ∃ x, x ∈ A ∧ f x y))

class has_infty_replacement_powerset extends has_infty α, has_replacement α, has_powerset α

class has_infty_replacement_powerset_sUnion extends has_infty_replacement_powerset α, has_sUnion α

variable {α}

instance has_infty.to_inhabited [has_infty α] : inhabited α :=
⟨∞⟩

def powerset [has_powerset α] : α → α :=
has_powerset.powerset

theorem zmem_powerset [has_powerset α] : ∀ {x z : α}, z ∈ powerset x ↔ z ⊆ x :=
has_powerset.zmem_powerset

def comprehension [has_comprehension α] : α → (α → Prop) → α :=
has_comprehension.comprehension

theorem zmem_comprehension_iff [has_comprehension α] : ∀ {A : α} {p x}, x ∈ comprehension A p ↔ x ∈ A ∧ p x :=
has_comprehension.zmem_comprehension_iff

def replacement [has_replacement α] : α → (α → α → Prop) → α :=
has_replacement.replacement

theorem zmem_replacement_iff [has_replacement α] {A} {f : α → α → Prop} {y} (H : ∀ A B C, f A B → f A C → B = C) :
  (y ∈ replacement A f ↔ ∃ x, x ∈ A ∧ f x y) :=
has_replacement.zmem_replacement_iff A f y H

instance has_comprehension.to_has_zempty [s : has_comprehension α] [inhabited α] : has_zempty α :=
{ emptyc := comprehension (inhabited.default α) (λ x, false),
  not_zmem_empty := λ x hx, begin
    simp [∅] at hx,
    rw [zmem_comprehension_iff] at hx,
    exact hx.2
  end,
  .. s }

instance has_replacement.to_has_comprehension [s : has_replacement α] : has_comprehension α :=
{ comprehension := λ A p, replacement A (λ x y, x = y ∧ p x),
  zmem_comprehension_iff := λ A p x, begin
    have h1 : ∀ A B C, A = B ∧ p A → A = C ∧ p A → B = C,
    { intros A B C h1 h2,
      rw [← h1.1, ← h2.1] },
    rw [zmem_replacement_iff h1],
    split,
    { intro H,
      rcases H with ⟨w, H1, H2, H3⟩,
      subst H2,
      exact ⟨H1, H3⟩ },
    { intro H,
      existsi x,
      simpa }
  end,
  .. s }

instance has_infty_replacement_powerset.to_has_zempty [s : has_infty_replacement_powerset α] : has_zempty α :=
{ .. s, .. has_comprehension.to_has_zempty }

instance has_infty_replacement_powerset.to_has_upair [s : has_infty_replacement_powerset α] : has_upair α :=
{ upair := λ x y, replacement (powerset (powerset ∅)) (λ m n, m = ∅ ∧ n = x ∨ m = powerset ∅ ∧ n = y),
     zmem_upair_iff_eq_or_eq := λ x y z, begin
       have h1 : ∀ (A B C : α),
         A = ∅ ∧ B = x ∨ A = powerset ∅ ∧ B = y →
         A = ∅ ∧ C = x ∨ A = powerset ∅ ∧ C = y → B = C,
       { intros A B C h1 h2,
         cases h1; cases h2;
         cases h1 with h3 h4;
         cases h2 with h5 h6,
         { subst h4, subst h6 },
         { exfalso,
           rw h3 at h5,
           have h7 : (∅:α) ∈ powerset ∅,
           { rw zmem_powerset,
             exact subset.refl ∅ },
           rw ← h5 at h7,
           exact not_zmem_empty h7 },
         { exfalso,
           rw h3 at h5,
           have h7 : (∅:α) ∈ powerset ∅,
           { rw zmem_powerset,
             exact subset.refl ∅ },
           rw h5 at h7,
           exact not_zmem_empty h7 },
         { subst h4, subst h6 } },
       rw zmem_replacement_iff h1,
       split,
       { intro H,
         rcases H with ⟨w, H1, ⟨H2, H3⟩ | ⟨H2, H3⟩⟩,
         { left, assumption },
         { right, assumption } },
       { intro H,
         cases H,
         { existsi ∅,
           split,
           { rw zmem_powerset,
             intros z hz,
             exfalso,
             exact not_zmem_empty hz },
           { left, split, refl, assumption } },
         { existsi powerset ∅,
           split,
           { rw zmem_powerset,
             exact subset.refl _ },
           { right, split, refl, assumption } } }
     end,
     .. s }

instance has_infty_replacement_powerset_sUnion.to_has_sUnion_upair [s : has_infty_replacement_powerset_sUnion α] : has_sUnion_upair α :=
{ .. s, .. has_infty_replacement_powerset.to_has_upair }

variable α

class has_zinfty extends has_infty α, has_infty_replacement_powerset_sUnion α :=
(empty_zmem_infinity : (∅:α) ∈ (∞:α))
(succ_zmem_infinity_of_zmem_infinity : ∀ x:α, x ∈ (∞:α) → succ x ∈ (∞:α))

class is_regular extends has_zmem α :=
(regular : ∀ x : α, (∃ y, y ∈ x) → (∃ y : α, y ∈ x ∧ ∀ z, z ∈ y → z ∈ x → false))

variable {α}

theorem empty_zmem_infinity [has_zinfty α] : (∅:α) ∈ (∞:α) :=
has_zinfty.empty_zmem_infinity α

theorem succ_zmem_infinity_of_zmem_infinity [has_zinfty α] : ∀ x:α, x ∈ (∞:α) → succ x ∈ (∞:α) :=
has_zinfty.succ_zmem_infinity_of_zmem_infinity

theorem regular [is_regular α] : ∀ x : α, (∃ y, y ∈ x) → (∃ y : α, y ∈ x ∧ ∀ z, z ∈ y → z ∈ x → false) :=
is_regular.regular

variable α

class zf extends has_zmem α, is_extensional α, has_sUnion α, has_powerset α, has_replacement α, has_zinfty α, is_regular α

section zf

variables {α} [zf α] {x y z : α}

theorem singleton_def : {x} = has_insert.insert x (∅:α) := rfl

theorem zmem_singleton_iff : x ∈ ({y}:α) ↔ x = y :=
begin
  rw [singleton_def, zmem_insert_iff_eq_or_zmem],
  apply or_iff_left_of_imp,
  intro H,
  exfalso,
  exact not_zmem_empty H
end

theorem zmem_singleton : x ∈ ({x}:α) :=
begin
  rw [singleton_def, zmem_insert_iff_eq_or_zmem],
  left, refl
end

theorem not_zmem_self : x ∉ x :=
λ h, begin
  rcases regular {x} ⟨x, zmem_singleton⟩ with ⟨y, h1, h2⟩,
  rw zmem_singleton_iff at h1,
  subst h1,
  exact h2 y h zmem_singleton
end

theorem not_zmem_and_zmem : x ∈ y → y ∈ x → false :=
λ hxy hyx, begin
  rcases regular {x, y} ⟨x, by simp [zmem_insert_iff_eq_or_zmem]; right; exact zmem_singleton⟩ with ⟨z, h1, h2⟩,
  rw [zmem_insert_iff_eq_or_zmem, zmem_singleton_iff] at h1,
  cases h1; subst h1,
  { apply h2 _ hxy,
    simp [zmem_insert_iff_eq_or_zmem],
    right, exact zmem_singleton },
  { apply h2 _ hyx,
    simp [zmem_insert_iff_eq_or_zmem] }
end

theorem succ.ext {x y : α} (H : succ x = succ y) : x = y :=
begin
  simp [succ] at H,
  have H1 : x ∈ has_insert.insert x x,
  { rw zmem_insert_iff_eq_or_zmem,
    left, refl },
  have H2 : y ∈ has_insert.insert y y,
  { rw zmem_insert_iff_eq_or_zmem,
    left, refl },
  rw [H, zmem_insert_iff_eq_or_zmem] at H1,
  rw [← H, zmem_insert_iff_eq_or_zmem] at H2,
  cases H1,
  { assumption },
  { cases H2,
    { subst H2 },
    { exfalso,
      exact not_zmem_and_zmem H1 H2 } }
end

def prod : α → α → α :=
λ X Y, comprehension (powerset $ powerset $ X ∪ Y) (λ z, ∃ x y, x ∈ X ∧ y ∈ Y ∧ z = opair x y)

theorem zmem_prod {A B : α} (hx : x ∈ A) (hy : y ∈ B) : opair x y ∈ prod A B :=
zmem_comprehension_iff.2
⟨zmem_powerset.2 $ λ z (hz : z ∈ opair x y),
   or.cases_on (zmem_upair_iff_eq_or_eq.1 hz)
     (λ hzx, zmem_powerset.2 $ λ w hw,
        or.cases_on (zmem_upair_iff_eq_or_eq.1 $ (hzx ▸ hw : w ∈ upair x x))
          (λ hwx, zmem_union_iff_zmem_or_zmem.2 $ or.inl $ hwx.symm ▸ hx)
          (λ hwx, zmem_union_iff_zmem_or_zmem.2 $ or.inl $ hwx.symm ▸ hx))
     (λ hzxy, zmem_powerset.2 $ λ w hw,
        or.cases_on (zmem_upair_iff_eq_or_eq.1 $ (hzxy ▸ hw : w ∈ upair x y))
          (λ hwx, zmem_union_iff_zmem_or_zmem.2 $ or.inl $ hwx.symm ▸ hx)
          (λ hwy, zmem_union_iff_zmem_or_zmem.2 $ or.inr $ hwy.symm ▸ hy)),
 x, y, hx, hy, rfl⟩

theorem zmem_left_of_zmem_prod {A B : α} (h : opair x y ∈ prod A B) : x ∈ A :=
let ⟨x1, y1, hx1, hy1, h⟩ := (zmem_comprehension_iff.1 h).2 in
(opair.ext h).1.symm ▸ hx1

theorem zmem_right_of_zmem_prod {A B : α} (h : opair x y ∈ prod A B) : y ∈ B :=
let ⟨x1, y1, hx1, hy1, h⟩ := (zmem_comprehension_iff.1 h).2 in
(opair.ext h).2.symm ▸ hy1

class is_relation (f : α) : Prop :=
(eq_opair_of_zmem : ∀ z, z ∈ f → ∃ x y, z = opair x y)

def dom (f : α) : α :=
replacement f (λ z x, ∃ y, z = opair x y)

def range (f : α) : α :=
replacement f (λ z y, ∃ x, z = opair x y)

class is_function (f : α) extends is_relation f : Prop :=
(exists_unique : ∀ x, x ∈ dom f → ∃! y, opair x y ∈ f)

class is_injective (f : α) extends is_function f : Prop :=
(injective : ∀ x y z, opair x z ∈ f → opair y z ∈ f → x = y)

theorem zmem_dom_iff {f x : α} : x ∈ dom f ↔ ∃ y, opair x y ∈ f :=
begin
  have h1 : ∀ (A B C : α), (∃ (y : α), A = opair B y) → (∃ (y : α), A = opair C y) → B = C,
  { intros A B C h1 h2,
    cases h1 with m h1,
    cases h2 with n h2,
    subst h1,
    exact (opair.ext h2).1 },
  rw [dom, zmem_replacement_iff h1],
  split; intro H,
  { rcases H with ⟨z, h1, w, h2⟩,
    subst h2, existsi w, assumption },
  { cases H with z h,
    existsi opair x z,
    split, assumption, existsi z, refl }
end

theorem zmem_range_iff {f y : α} : y ∈ range f ↔ ∃ x, opair x y ∈ f :=
begin
  have h1 : ∀ (A B C : α), (∃ (x : α), A = opair x B) → (∃ (x : α), A = opair x C) → B = C,
  { intros A B C h1 h2,
    cases h1 with m h1,
    cases h2 with n h2,
    subst h1,
    exact (opair.ext h2).2 },
  rw [range, zmem_replacement_iff h1],
  split; intro H,
  { rcases H with ⟨z, h1, w, h2⟩,
    subst h2, existsi w, assumption },
  { cases H with z h,
    existsi opair z y,
    split, assumption, existsi z, refl }
end

theorem zmem_dom_of_opair_zmem {f : α} [is_function f] {x y : α} (H : opair x y ∈ f) : x ∈ dom f :=
zmem_dom_iff.2 ⟨_, H⟩

theorem zmem_range_of_opair_zmem {f : α} [is_function f] {x y : α} (H : opair x y ∈ f) : y ∈ range f :=
zmem_range_iff.2 ⟨_, H⟩

def eval (f : α) [is_function f] (x : α) : α :=
sUnion $ comprehension (range f) (λ y, opair x y ∈ f)

theorem eval_unique {f : α} [is_function f] {x y : α} (H : x ∈ dom f) (Hxy : opair x y ∈ f) : y = eval f x :=
begin
  rcases is_function.exists_unique _ H with ⟨y', H1, H2⟩,
  have H3 := H2 _ Hxy, subst H3,
  apply is_extensional.ext,
  intro z, split; intro hz,
  { rw [eval, zmem_sUnion_iff_zmem_zmem],
    existsi y,
    rw [zmem_comprehension_iff, zmem_range_iff],
    exact ⟨hz, ⟨x, Hxy⟩, Hxy⟩ },
  { rw [eval, zmem_sUnion_iff_zmem_zmem] at hz,
    rcases hz with ⟨t, ht1, ht2⟩,
    rw [zmem_comprehension_iff, zmem_range_iff] at ht2,
    specialize H2 _ ht2.2,
    subst H2,
    exact ht1 }
end

theorem opair_eval_zmem {f : α} [is_function f] {x : α} (H : x ∈ dom f) : opair x (eval f x) ∈ f :=
begin
  rcases is_function.exists_unique _ H with ⟨y, H1, H2⟩,
  have H3 := eval_unique H H1,
  subst H3,
  exact H1
end

theorem eval_zmem_range {f : α} [is_function f] {x : α} (H : x ∈ dom f) : eval f x ∈ range f :=
zmem_range_iff.2 ⟨_, opair_eval_zmem H⟩

def inv (f : α) : α :=
replacement f (λ x y, ∃ m n, opair m n = x ∧ opair n m = y)

theorem inv.aux (A B C : α)
  (H1 : ∃ (m n : α), opair m n = A ∧ opair n m = B)
  (H2 : ∃ (m n : α), opair m n = A ∧ opair n m = C) :
  B = C :=
begin
  rcases H1 with ⟨m1, n1, H3, H4⟩,
  rcases H2 with ⟨m2, n2, H5, H6⟩,
  subst H3, subst H4, subst H6,
  rw opair.iff at H5 ⊢,
  cases H5 with H1 H2,
  split; symmetry; assumption
end

theorem zmem_inv_iff {f x y : α} : opair x y ∈ inv f ↔ opair y x ∈ f :=
begin
  rw [inv, zmem_replacement_iff inv.aux],
  split; intro h,
  { rcases h with ⟨z, hz, m, n, h1, h2⟩,
    rcases opair.ext h2 with ⟨h3, h4⟩,
    subst h1, subst h3, subst h4,
    exact hz },
  { exact ⟨_, h, _, _, rfl, rfl⟩ }
end

instance inv.is_relation (f : α) : is_relation (inv f) :=
{ eq_opair_of_zmem := begin
    intros z hz,
    rw [inv, zmem_replacement_iff inv.aux] at hz,
    rcases hz with ⟨x, hxf, m, n, h1, h2⟩,
    subst h2,
    exact ⟨_, _, rfl⟩
  end }

instance inv.is_injective (f : α) [is_injective f] : is_injective (inv f) :=
{ exists_unique := begin
    intros x hx,
    rw zmem_dom_iff at hx,
    cases hx with y hy,
    existsi y,
    split,
    { exact hy },
    { intros z hz,
      rw zmem_inv_iff at hy hz,
      exact is_injective.injective _ _ _ hz hy }
  end,
  injective := begin
    intros x y z hx hy,
    rw zmem_inv_iff at hx hy,
    have h1 : z ∈ dom f,
    { rw zmem_dom_iff,
      exact ⟨_, hy⟩ },
    have h2 := is_function.exists_unique z h1,
    exact unique_of_exists_unique h2 hx hy
  end,
  .. inv.is_relation f }

theorem inv.dom {f : α} : dom (inv f) = range f :=
begin
  apply is_extensional.ext,
  intro z,
  rw [zmem_dom_iff, zmem_range_iff],
  split; intro hz,
  { cases hz with y h,
    rw zmem_inv_iff at h,
    exact ⟨_, h⟩ },
  { cases hz with y h,
    existsi y,
    rw zmem_inv_iff,
    exact h }
end

theorem inv.range {f : α} : range (inv f) = dom f :=
begin
  apply is_extensional.ext,
  intro z,
  rw [zmem_dom_iff, zmem_range_iff],
  split; intro hz,
  { cases hz with y h,
    rw zmem_inv_iff at h,
    exact ⟨_, h⟩ },
  { cases hz with y h,
    existsi y,
    rw zmem_inv_iff,
    exact h }
end

variable α

def omega : α :=
comprehension ∞ (λ n, ∀ A:α, ∅ ∈ A → (∀ k, k ∈ A → succ k ∈ A) → n ∈ A)

notation `ω` := omega _

variable {α}

theorem empty_zmem_omega : (∅:α) ∈ (ω:α) :=
zmem_comprehension_iff.2 ⟨empty_zmem_infinity, λ A h1 h2, h1⟩

theorem succ_zmem_omega_of_zmem (H : x ∈ (ω:α)) : succ x ∈ (ω:α) :=
zmem_comprehension_iff.2
⟨succ_zmem_infinity_of_zmem_infinity x $ (zmem_comprehension_iff.1 H).1,
 λ A h1 h2, h2 x $ (zmem_comprehension_iff.1 H).2 A h1 h2⟩

theorem induction (p : α → Prop) (H1 : p ∅) (H2 : ∀ k, k ∈ omega α → p k → p (succ k)) (n : α) (Hn : n ∈ omega α) : p n :=
(zmem_comprehension_iff.1 $
 (zmem_comprehension_iff.1 Hn).2 (comprehension (omega α) p)
  (zmem_comprehension_iff.2 ⟨empty_zmem_omega, H1⟩)
  (λ k hk, zmem_comprehension_iff.2
   ⟨succ_zmem_omega_of_zmem $ (zmem_comprehension_iff.1 hk).1,
   H2 k (zmem_comprehension_iff.1 hk).1 (zmem_comprehension_iff.1 hk).2⟩)).2

theorem omega.structure (H : x ∈ (ω:α)) : x = ∅ ∨ ∃ y ∈ (ω:α), x = succ y :=
@induction α _ (λ z:α, z = ∅ ∨ ∃ y ∈ (ω:α), z = succ y)
  (or.inl rfl)
  (λ k hk1 hk2, or.inr ⟨k, hk1, rfl⟩)
  x H

class is_transitive (x : α) : Prop :=
(zmem_trans : ∀ m n, m ∈ n → n ∈ x → m ∈ x)

instance omega.transitive : is_transitive (ω:α) :=
{ zmem_trans := λ m n hmn hno, @induction α _ (λ z, ∀ x, x ∈ z → x ∈ (ω:α))
    (λ x hx, false.elim $ not_zmem_empty hx)
    (λ k hk1 hk2 x hx, or.cases_on (zmem_succ_iff_eq_or_zmem.1 hx)
       (λ hxk, hxk.symm ▸ hk1)
       (hk2 x))
    n hno m hmn }

variable α

def nat.to_omega : nat → α
| nat.zero     := ∅
| (nat.succ n) := succ (n.to_omega)

theorem nat.to_omega.zmem_omega : ∀ n, nat.to_omega α n ∈ omega α
| nat.zero     := empty_zmem_omega
| (nat.succ n) := succ_zmem_omega_of_zmem $ nat.to_omega.zmem_omega n

def nat.to_omega' : nat → {x // x ∈ omega α} :=
λ n, ⟨nat.to_omega α n, nat.to_omega.zmem_omega α n⟩

theorem nat.to_omega.injective : function.injective (nat.to_omega α) :=
begin
  intros m n H,
  induction m with m ihm generalizing n H;
  induction n with n ihn,
  { refl },
  { exfalso,
    have h1 : nat.to_omega α n ∈ nat.to_omega α (nat.succ n),
    { unfold nat.to_omega,
      unfold succ,
      rw zmem_insert_iff_eq_or_zmem,
      left, refl },
    rw ← H at h1,
    exact not_zmem_empty h1 },
  { exfalso,
    have h1 : nat.to_omega α m ∈ nat.to_omega α (nat.succ m),
    { unfold nat.to_omega,
      unfold succ,
      rw zmem_insert_iff_eq_or_zmem,
      left, refl },
    rw H at h1,
    exact not_zmem_empty h1 },
  { unfold nat.to_omega at H,
    congr,
    exact ihm (succ.ext H) }
end

-- it isn't supposed to be surjective unless the model is transitive
theorem nat.to_omega.surjective_cheating : function.surjective (nat.to_omega' α) :=
begin
  intros x,
  cases x with x hx,
  dsimp [omega] at hx,
  rw zmem_comprehension_iff at hx,
  cases hx with h1 h2,
  let cheating := comprehension (omega α) (nat.to_omega α '' set.univ),
  specialize h2 cheating,
  simp [cheating, zmem_comprehension_iff] at h2,
  specialize h2 empty_zmem_omega,
  specialize h2 ⟨0, rfl⟩,
  specialize h2 (λ k hk1 ⟨n, hk2⟩, ⟨succ_zmem_omega_of_zmem hk1, nat.succ n, by rw ← hk2; refl⟩),
  rcases h2 with ⟨h2, n, h3⟩,
  existsi n,
  apply subtype.eq,
  exact h3
end

variable {α}

section erase

def erase (x y : α) : α :=
comprehension x (λ z, z ≠ y)

theorem zmem_erase_iff : z ∈ erase x y ↔ z ∈ x ∧ z ≠ y :=
zmem_comprehension_iff

theorem zmem_of_zmem_erase (H : z ∈ erase x y) : z ∈ x :=
(zmem_erase_iff.1 H).1

theorem ne_of_zmem_erase (H : z ∈ erase x y) : z ≠ y :=
(zmem_erase_iff.1 H).2

theorem zmem_erase_of_zmem_of_ne (H1 : z ∈ x) (H2 : z ≠ y) : z ∈ erase x y :=
zmem_erase_iff.2 ⟨H1, H2⟩

end erase

section recursion

variables (f A c : α) [is_function f] (H1 : dom f = prod ω A) (H2 : range f ⊆ A) (H3 : c ∈ A)

-- {(x,y) ∈ ω × A | ∃ h : ω → A, h(∅) = c ∧ (∀ m ∈ x, h(m⁺) = f(m, h(m))) ∧ h(x) = y}
def recursion : α :=
comprehension (prod ω A)
(λ z, ∃ (h x y : α) [is_function h] (H4 : z = opair x y) (H5 : dom h = ω) (H6 : range h ⊆ A)
 (H7 : opair ∅ c ∈ h) (H8: ∀ m hm hsm, m ∈ x → opair m hm ∈ h → opair (opair m hm) hsm ∈ f → opair (succ m) hsm ∈ h), z ∈ h)

include H3

theorem recursion.empty : opair ∅ c ∈ recursion f A c :=
begin
  let h : α := prod ω {c},
  have hf : is_function h,
  { split,
    { intros z hz,
      dsimp [h] at hz,
      rw [prod, zmem_comprehension_iff] at hz,
      replace hz := hz.2,
      rcases hz with ⟨x', y', _, _, h'⟩,
      exact ⟨x', y', h'⟩ },
    { intros x' hx',
      existsi c,
      rw [zmem_dom_iff] at hx',
      rcases hx' with ⟨y, hy⟩,
      dsimp [h] at hy ⊢,
      split,
      { exact zmem_prod (zmem_left_of_zmem_prod hy) zmem_singleton },
      { intros y' hy',
        replace hy' := zmem_right_of_zmem_prod hy',
        rwa zmem_singleton_iff at hy' } } },
  have H5 : dom h = ω,
  { apply is_extensional.ext,
    intro z,
    rw [zmem_dom_iff],
    split; intro h5,
    { cases h5 with y hy,
      exact zmem_left_of_zmem_prod hy },
    { existsi c,
      exact zmem_prod h5 zmem_singleton } },
  have H6 : range h ⊆ A,
  { intros z hz,
    rw [zmem_range_iff] at hz,
    cases hz with y hy,
    replace hy := zmem_right_of_zmem_prod hy,
    rw zmem_singleton_iff at hy,
    subst hy,
    exact H3 },
  have H7 : opair ∅ c ∈ h,
  { exact zmem_prod empty_zmem_omega zmem_singleton },
  rw [recursion, zmem_comprehension_iff],
  split,
  { exact zmem_prod empty_zmem_omega H3 },
  { exact ⟨h, _, _, hf, rfl, H5, H6, H7, (λ m _ _ hm, false.elim $ not_zmem_empty hm), H7⟩ }
end

omit H3
include H1 H2 H3

theorem recursion.succ (h1 : opair x y ∈ recursion f A c) (h2 : opair (opair x y) z ∈ f) : opair (succ x) z ∈ recursion f A c :=
begin
  have h3 : opair x y ∈ prod ω A,
  { rw [← H1, zmem_dom_iff], exact ⟨z, h2⟩ },
  have h5 : z ∈ A,
  { apply H2, rw [zmem_range_iff], exact ⟨_, h2⟩ },
  rw [recursion, zmem_comprehension_iff] at h1,
  cases h1 with h1 h3,
  rcases h3 with ⟨h, x', y', hf, H4, H5, H6, H7, H8, H9⟩,
  have h4 : opair x y ∈ dom f,
  { rw H1, exact h1 },
  let h' : α := comprehension (prod ω A) (λ w, ∀ m n, w = opair m n → ((m = succ x ∧ n = z) ∨ (m ≠ succ x ∧ w ∈ h))),
  have hf' : is_function h' :=
  { eq_opair_of_zmem := λ z hz, begin
        dsimp [h'] at hz,
        rw [zmem_comprehension_iff] at hz,
        cases hz with hz1 hz2,
        rw [prod, zmem_comprehension_iff] at hz1,
        rcases hz1.2 with ⟨x'', y'', _, _, h''⟩,
        exact ⟨x'', y'', h''⟩
      end,
    exists_unique := begin
        intros x hx,
        rw [zmem_dom_iff] at hx,
        cases hx with y hy,
        dsimp [h'] at hy,
        rw [zmem_comprehension_iff] at hy,
        cases hy with hy1 hy2,
        specialize hy2 x y rfl,
        cases hy2 with hy2 hy2;
        cases hy2 with hy2 hy3,
        { existsi y,
          split,
          { dsimp [h'],
            rw [zmem_comprehension_iff],
            split, exact hy1,
            intros m n hxy,
            cases opair.ext hxy with hxy1 hxy2,
            subst hxy1, subst hxy2,
            left, split, subst hy2, subst hy3 },
          { intros z hz,
            dsimp [h'] at hz,
            rw [zmem_comprehension_iff] at hz,
            cases hz with hz1 hz2,
            specialize hz2 _ _ rfl,
            cases hz2 with hz2 hz2;
            cases hz2 with hz2 hz3,
            { subst hy3, subst hz3 },
            { exfalso, exact hz2 hy2 } } },
        { existsi y,
          split,
          { dsimp [h'],
            rw [zmem_comprehension_iff],
            split, exact hy1,
            intros m n hxy,
            cases opair.ext hxy with hxy1 hxy2,
            subst hxy1, subst hxy2,
            right, split, exact hy2, exact hy3 },
          { intros z hz,
            dsimp [h'] at hz,
            rw [zmem_comprehension_iff] at hz,
            cases hz with hz1 hz2,
            specialize hz2 _ _ rfl,
            cases hz2 with hz2 hz2;
            cases hz2 with hz2 hz3,
            { exfalso, exact hy2 hz2 },
            { have hf1 := hf.exists_unique,
              have hf2 : x ∈ dom h,
              { rw [zmem_dom_iff], existsi y, exact hy3 },
              specialize hf1 _ hf2,
              exact unique_of_exists_unique hf1 hz3 hy3 } } }
      end },
  have H5' : dom h' = ω,
  { apply is_extensional.ext,
    intro w,
    rw [zmem_dom_iff],
    split; intro hw,
    { cases hw with w hw,
      dsimp [h'] at hw,
      rw [zmem_comprehension_iff] at hw,
      cases hw with hw1 hw2,
      exact zmem_left_of_zmem_prod hw1 },
    { cases classical.em (w = succ x) with hzk hzk,
      { existsi z,
        dsimp [h'],
        rw [zmem_comprehension_iff],
        split,
        { exact zmem_prod hw h5 },
        { intros m n hmn,
          cases opair.ext hmn with hmn1 hmn2,
          subst hmn1, subst hmn2,
          left, split, exact hzk, refl } },
      { have hf1 := hf.exists_unique,
        specialize hf1 w (H5.symm ▸ hw),
        rcases hf1 with ⟨w', hf1, hf2⟩,
        existsi w',
        dsimp [h'],
        rw [zmem_comprehension_iff],
        split,
        have hf3 : w' ∈ range h,
        { rw [zmem_range_iff], existsi w, exact hf1 },
        { exact zmem_prod hw (H6 _ hf3) },
        { intros m n hmn,
          cases opair.ext hmn with hmn1 hmn2,
          subst hmn1, subst hmn2,
          right, split, exact hzk, exact hf1 } } } },
  have H6' : range h' ⊆ A,
  { intros z hz,
    rw [zmem_range_iff] at hz,
    cases hz with w hw,
    dsimp [h'] at hw,
    rw [zmem_comprehension_iff] at hw,
    cases hw with hw1 hw2,
    specialize hw2 _ _ rfl,
    cases hw2 with hw2 hw2;
    cases hw2 with hw2 hw3,
    { subst hw3,
      apply H2,
      rw [zmem_range_iff],
      exact ⟨_, h2⟩ },
    { have hf1 : z ∈ range h,
      { rw [zmem_range_iff], existsi w, exact hw3 },
      exact H6 _ hf1 } },
  have H7' : opair ∅ c ∈ h',
  { dsimp [h'],
    rw [zmem_comprehension_iff],
    split,
    { exact zmem_prod empty_zmem_omega H3 },
    { intros m n hmn,
      cases opair.ext hmn with hmn1 hmn2,
      subst hmn1, subst hmn2,
      right, split,
      { intro hmn1,
        have hmn2 : x ∈ succ x := zmem_succ,
        rw ← hmn1 at hmn2,
        exact not_zmem_empty hmn2 },
      { exact H7 } } },
  have H8' : ∀ (m hm hsm : α), m ∈ succ x → opair m hm ∈ h' → opair (opair m hm) hsm ∈ f → opair (succ m) hsm ∈ h',
  { intros m hm hsm hm1 hm2 hm3,
    rw zmem_succ_iff_eq_or_zmem at hm1,
    cases hm1 with hm1 hm1,
    { subst hm1,
      dsimp [h'],
      rw [zmem_comprehension_iff],
      have hm4 : hsm ∈ range f,
      { rw [zmem_range_iff], existsi _, exact hm3 },
      have hm5 : m ∈ ω,
      { rw ← H5', rw [zmem_dom_iff], existsi _, exact hm2 },
      split,
      { exact zmem_prod (succ_zmem_omega_of_zmem hm5) (H2 _ hm4) },
      { intros m n hmn,
        cases opair.ext hmn with hmn1 hmn2,
        subst hmn1, subst hmn2,
        left, split, refl,
        dsimp [h'] at hm2,
        rw [zmem_comprehension_iff] at hm2,
        cases hm2 with hm8 hm6,
        specialize hm6 _ _ rfl,
        cases hm6 with hm6 hm6;
        cases hm6 with hm6 hm7,
        { exfalso,
          have hm9 : m ∈ succ m := zmem_succ,
          rw ← hm6 at hm9,
          exact not_zmem_self hm9 },
        { have hf1 := hf.exists_unique,
          have hf2 : m ∈ dom h,
          { rw H5, exact hm5 },
          specialize hf1 _ hf2,
          have hf3 := unique_of_exists_unique hf1 hm7 H9,
          subst hf3,
          have hf4 := is_function.exists_unique _ h4,
          exact unique_of_exists_unique hf4 hm3 h2 } } },
    { cases opair.ext H4 with H41 H42,
      subst H41, subst H42,
      dsimp [h'],
      rw [zmem_comprehension_iff],
      have hm4 : hsm ∈ range f,
      { rw [zmem_range_iff], existsi _, exact hm3 },
      have hm5 : m ∈ ω,
      { rw ← H5', rw [zmem_dom_iff], existsi _, exact hm2 },
      split,
      { exact zmem_prod (succ_zmem_omega_of_zmem hm5) (H2 _ hm4) },
      { intros m n hmn,
        cases opair.ext hmn with hmn1 hmn2,
        subst hmn1, subst hmn2,
        right, split,
        { intro hmk,
          replace hmk := succ.ext hmk,
          subst hmk,
          exact not_zmem_self hm1 },
        { have hm6 : opair m hm ∈ h,
          { dsimp [h'] at hm2,
            rw [zmem_comprehension_iff] at hm2,
            cases hm2 with hm8 hm6,
            specialize hm6 _ _ rfl,
            cases hm6 with hm6 hm6;
            cases hm6 with hm6 hm7,
            { exfalso,
              subst hm6,
              apply not_zmem_and_zmem hm1 zmem_succ },
            { exact hm7 } },
          exact H8 _ _ _ hm1 hm6 hm3 } } } },
  have H9' : opair (succ x) z ∈ h',
  { dsimp [h'],
    rw [zmem_comprehension_iff],
    split,
    { exact zmem_prod (succ_zmem_omega_of_zmem $ zmem_left_of_zmem_prod h3) h5 },
    { intros m n hmn,
      cases opair.ext hmn with hmn1 hmn2,
      subst hmn1, subst hmn2,
      left, split, refl, refl } },
  rw [recursion, zmem_comprehension_iff],
  split,
  { exact zmem_prod (succ_zmem_omega_of_zmem $ zmem_left_of_zmem_prod h3) h5 },
  { exact ⟨h', _, _, hf', rfl, H5', H6', H7', H8', H9'⟩ }
end

theorem recursion.dom_omega (n : α) (Hn : n ∈ (ω:α)) : ∃! y, opair n y ∈ recursion f A c :=
begin
  apply @induction _ _ _ _ _ n Hn,
  { existsi c,
    split,
    { exact recursion.empty f A c H3 },
    { intros y h1,
      rw [recursion, zmem_comprehension_iff] at h1,
      rcases h1 with ⟨h1, h, x', y', hf, H4, H5, H6, H7, H8, H9⟩,
      have hf1 := hf.exists_unique,
      specialize hf1 ∅ (H5.symm ▸ empty_zmem_omega),
      exact unique_of_exists_unique hf1 H9 H7 } },
  { intros k hk h1,
    rcases h1 with ⟨y, h1, h2⟩,
    have h4 : opair k y ∈ dom f,
    { rw [recursion, zmem_comprehension_iff] at h1,
      rw H1, exact h1.1 },
    existsi (eval f (opair k y)),
    split,
    { exact recursion.succ f A c H1 H2 H3 h1 (opair_eval_zmem h4) },
    { intros z hz,
      apply eval_unique h4,
      rw [recursion, zmem_comprehension_iff] at hz,
      rcases hz with ⟨hz1, h'', x'', y'', hf'', H4'', H5'', H6'', H7'', H8'', H9''⟩,
      cases opair.ext H4'' with H41'' H42'',
      subst H41'', subst H42'',
      rw [recursion, zmem_comprehension_iff] at h1,
      cases h1 with h1 h3,
      rcases h3 with ⟨h, x', y', hf, H4, H5, H6, H7, H8, H9⟩,      cases opair.ext H4 with H41 H42,
      subst H41, subst H42,
      cases omega.structure hk with h3 h3,
      { subst h3,
        have hf1 := hf.exists_unique,
        specialize hf1 ∅ (H5.symm ▸ empty_zmem_omega),
        have hf2 := unique_of_exists_unique hf1 H9 H7,
        subst hf2,
        specialize H8'' ∅ _ _ zmem_succ H7'' (opair_eval_zmem h4),
        have hf3 := hf''.exists_unique,
        specialize hf3 (succ ∅) (H5''.symm ▸ succ_zmem_omega_of_zmem empty_zmem_omega),
        have hf2 := unique_of_exists_unique hf3 H8'' H9'',
        subst hf2,
        apply opair_eval_zmem h4 },
      { rcases h3 with ⟨k, H, hk⟩, subst hk,
        have h5 : succ k ∈ dom h'',
        { rw H5'', exact hk },
        have h6 : opair (succ k) (@@eval _ h'' hf'' (succ k)) ∈ recursion f A c,
        { rw [recursion, zmem_comprehension_iff],
          split,
          { exact zmem_prod hk (H6'' _ $ @eval_zmem_range _ _ _ hf'' _ h5) },
          { exact ⟨h'', _, _, hf'', rfl, H5'', H6'', H7'',
              (λ m hm hsm hm1 hm2 hm3, H8'' m hm hsm (zmem_succ_of_zmem hm1) hm2 hm3),
              @opair_eval_zmem _ _ _ hf'' _ h5⟩ } },
        specialize H8'' _ _ _ zmem_succ (@opair_eval_zmem _ _ _ hf'' _ h5)
          (opair_eval_zmem (H1.symm ▸ zmem_prod hk (H6'' _ $ @eval_zmem_range _ _ _ hf'' _ h5))),
        specialize h2 _ h6,
        subst h2,
        have hf3 := hf''.exists_unique,
        specialize hf3 (succ (succ k)) (H5''.symm ▸ succ_zmem_omega_of_zmem hk),
        have hf2 := unique_of_exists_unique hf3 H8'' H9'',
        subst hf2,
        apply opair_eval_zmem h4 } } }
end

instance recursion.is_function : is_function (recursion f A c) :=
{ eq_opair_of_zmem := λ z hz, let ⟨x, y, _, _, h⟩ := (zmem_comprehension_iff.1 (zmem_comprehension_iff.1 hz).1).2 in ⟨x, y, h⟩,
  exists_unique := λ x hx, begin
    rw [zmem_dom_iff] at hx,
    cases hx with w hw,
    rw [recursion, zmem_comprehension_iff] at hw,
    have hx : x ∈ ω := zmem_left_of_zmem_prod hw.1,
    exact recursion.dom_omega f A c H1 H2 H3 x hx
  end }

theorem recursion.dom : dom (recursion f A c) = ω :=
begin
  apply is_extensional.ext,
  intro n,
  rw [zmem_dom_iff],
  split; intro hn,
  { cases hn with y hy,
    rw [recursion, zmem_comprehension_iff] at hy,
    exact zmem_left_of_zmem_prod hy.1 },
  { rcases recursion.dom_omega f A c H1 H2 H3 n hn with ⟨y, h1, h2⟩,
    exact ⟨y, h1⟩ }
end

theorem recursion.range : range (recursion f A c) ⊆ A :=
begin
  intros z hz,
  rw [zmem_range_iff] at hz,
  cases hz with n hn,
  rw [recursion, zmem_comprehension_iff] at hn,
  exact zmem_right_of_zmem_prod hn.1
end

-- recursion theorem:
-- for any function f : ω×A → A and c ∈ A, there is a unique function h : ω → A such that:
-- 1. h(0) = c
-- 2. h(m⁺) = f(m,h(m))
-- (I left uniqueness unproved)

end recursion

section transitive_closure

def transitive_closure (z : α) : α :=
sUnion $ replacement ω (λ x y, ∃ (A : α) (H1 : x ∈ (ω:α)) (H2 : ∀ p q r, opair p q ∈ A → opair p r ∈ A → q = r)
  (H3 : ∀ p q, opair p q ∈ A → p ∈ succ x) (H4 : ∀ p, p ∈ x → ∃ q, opair p q ∈ A) (H5 : opair ∅ z ∈ A)
  (H6 : ∀ p q, p ∈ x → opair p q ∈ A → opair (succ p) (sUnion q) ∈ A), opair x y ∈ A)

theorem transitive_closure.aux.empty : ∃ (A : α) (H1 : (∅:α) ∈ (ω:α)) (H2 : ∀ (p q r : α), opair p q ∈ A → opair p r ∈ A → q = r)
    (H3 : ∀ (p q : α), opair p q ∈ A → p ∈ succ (∅:α))
    (H4 : ∀ (p : α), p ∈ (∅:α) → (∃ (q : α), opair p q ∈ A)) (H5 : opair ∅ z ∈ A)
    (H6 : ∀ (p q : α), p ∈ (∅:α) → opair p q ∈ A → opair (succ p) (sUnion q) ∈ A),
    opair ∅ z ∈ A :=
begin
  have H2 : ∀ (p q r : α), opair p q ∈ {opair ∅ z} → opair p r ∈ {opair ∅ z} → q = r,
  { intros p q r hpq hpr,
    rw zmem_singleton_iff at hpq hpr,
    have h1 := (opair.ext hpq).2,
    have h2 := (opair.ext hpr).2,
    subst h1, subst h2 },
  have H3 : ∀ (p q : α), opair p q ∈ {opair ∅ z} → p ∈ succ (∅:α),
  { intros p q h,
    rw zmem_singleton_iff at h,
    rw (opair.ext h).1,
    exact zmem_succ },
  exact ⟨{opair ∅ z}, empty_zmem_omega, H2, H3, (λ p hp, false.elim $ not_zmem_empty hp),
    zmem_singleton, (λ p q hp, false.elim $ not_zmem_empty hp), zmem_singleton⟩
end

theorem transitive_closure.aux.succ {k : α} (hk : k ∈ (ω:α)) :
  (∃ (A : α) (H1 : k ∈ (ω:α)) (H2 : ∀ (p q r : α), opair p q ∈ A → opair p r ∈ A → q = r)
     (H3 : ∀ (p q : α), opair p q ∈ A → p ∈ succ k)
     (H4 : ∀ (p : α), p ∈ k → (∃ (q : α), opair p q ∈ A)) (H5 : opair ∅ z ∈ A)
     (H6 : ∀ (p q : α), p ∈ k → opair p q ∈ A → opair (succ p) (sUnion q) ∈ A),
     opair k y ∈ A)
  →
  (∃ (A : α) (H1 : succ k ∈ (ω:α)) (H2 : ∀ (p q r : α), opair p q ∈ A → opair p r ∈ A → q = r)
     (H3 : ∀ (p q : α), opair p q ∈ A → p ∈ succ (succ k))
     (H4 : ∀ (p : α), p ∈ succ k → (∃ (q : α), opair p q ∈ A)) (H5 : opair ∅ z ∈ A)
     (H6 : ∀ (p q : α), p ∈ succ k → opair p q ∈ A → opair (succ p) (sUnion q) ∈ A),
     opair (succ k) (sUnion y) ∈ A) :=
begin
  intro h1,
  rcases h1 with ⟨A, H1, H2, H3, H4, H5, H6, H7⟩,
  have H2' : ∀ (p q r : α),
    opair p q ∈ has_insert.insert (opair (succ k) (sUnion y)) A →
    opair p r ∈ has_insert.insert (opair (succ k) (sUnion y)) A →
    q = r,
  { intros p q r hpq hpr,
    rw zmem_insert_iff_eq_or_zmem at hpq hpr,
    cases hpq; cases hpr,
    { have h1 := (opair.ext hpq).2,
      have h2 := (opair.ext hpr).2,
      subst h1, subst h2 },
    { exfalso,
      have h1 := (opair.ext hpq).1,
      subst h1,
      exact not_zmem_self (H3 _ _ hpr) },
    { exfalso,
      have h1 := (opair.ext hpr).1,
      subst h1,
      exact not_zmem_self (H3 _ _ hpq) },
    { exact H2 _ _ _ hpq hpr } },
  have H3' : ∀ (p q : α), opair p q ∈ has_insert.insert (opair (succ k) (sUnion y)) A → p ∈ succ (succ k),
  { intros p q h,
    rw zmem_insert_iff_eq_or_zmem at h,
    cases h with h h,
    { rw (opair.ext h).1,
      exact zmem_succ },
    { exact zmem_succ_of_zmem (H3 _ _ h) } },
  have H4' : ∀ (p : α), p ∈ succ k → (∃ (q : α), opair p q ∈ has_insert.insert (opair (succ k) (sUnion y)) A),
  { intros p hp,
    rw zmem_succ_iff_eq_or_zmem at hp,
    cases hp with hp hp,
    { subst hp,
      existsi y,
      exact zmem_insert_of_zmem H7 },
    { cases H4 p hp with q hq,
      exact ⟨q, zmem_insert_of_zmem hq⟩ } },
  have H6' : ∀ (p q : α), p ∈ succ k →
    opair p q ∈ has_insert.insert (opair (succ k) (sUnion y)) A →
    opair (succ p) (sUnion q) ∈ has_insert.insert (opair (succ k) (sUnion y)) A,
  { intros p q hp hpq,
    rw zmem_succ_iff_eq_or_zmem at hp,
    rw zmem_insert_iff_eq_or_zmem at hpq,
    cases hp with hp hp;
    cases hpq with hpq hpq,
    { subst hp,
      exfalso,
      have h1 : p ∈ succ p := zmem_succ,
      rw ← (opair.ext hpq).1 at h1,
      exact not_zmem_self h1 },
    { subst hp,
      rw H2 _ _ _ hpq H7,
      exact zmem_insert },
    { exfalso,
      apply not_zmem_and_zmem hp,
      rw (opair.ext hpq).1,
      exact zmem_succ },
    { exact zmem_insert_of_zmem (H6 _ _ hp hpq) } },
  exact ⟨has_insert.insert (opair (succ k) (sUnion y)) A,
  succ_zmem_omega_of_zmem hk, H2', H3', H4',
  zmem_insert_of_zmem H5, H6', zmem_insert⟩
end

theorem transitive_closure.aux : ∀ x, x ∈ (ω:α) → ∃! y,
  ∃ (A : α) (H1 : x ∈ (ω:α)) (H2 : ∀ p q r, opair p q ∈ A → opair p r ∈ A → q = r)
  (H3 : ∀ p q, opair p q ∈ A → p ∈ succ x) (H4 : ∀ p, p ∈ x → ∃ q, opair p q ∈ A) (H5 : opair ∅ z ∈ A)
  (H6 : ∀ p q, p ∈ x → opair p q ∈ A → opair (succ p) (sUnion q) ∈ A), opair x y ∈ A :=
begin
  apply induction,
  { existsi z,
    split,
    { exact transitive_closure.aux.empty },
    { intros y hy,
      rcases hy with ⟨A, H1, H2, H3, H4, H5, H6, H7⟩,
      exact H2 _ _ _ H7 H5 } },
  { intros k hk ih,
    rcases ih with ⟨y, h1, h2⟩,
    existsi sUnion y,
    split,
    { exact transitive_closure.aux.succ hk h1 },
    { intros w hw,
      rcases hw with ⟨A', H1', H2', H3', H4', H5', H6', H7'⟩,
      cases H4' _ zmem_succ with q hq,
      have h := H2' _ _ _ H7' (H6' _ _ zmem_succ hq), subst h,
      congr,
      have H3'' : ∀ (p q_1 : α), opair p q_1 ∈ erase A' (opair (succ k) (sUnion q)) → p ∈ succ k,
      { intros p q h,
        have h1 := H3' _ _ (zmem_of_zmem_erase h),
        cases zmem_succ_iff_eq_or_zmem.1 h1 with h3 h3,
        { exfalso, subst h3,
          have h3 := H2' _ _ _ (H6' _ _ zmem_succ hq) (zmem_of_zmem_erase h), subst h3,
          exact ne_of_zmem_erase h rfl },
        { exact h3 } },
      have H4'' : ∀ (p : α), p ∈ k → (∃ (q_1 : α), opair p q_1 ∈ erase A' (opair (succ k) (sUnion q))),
      { intros p hp,
        cases H4' p (zmem_succ_of_zmem hp) with q hq,
        existsi q,
        apply zmem_erase_of_zmem_of_ne hq,
        intro h,
        rw (opair.ext h).1 at hp,
        exact not_zmem_and_zmem hp zmem_succ },
      have H5'' : opair ∅ z ∈ erase A' (opair (succ k) (sUnion q)),
      { apply zmem_erase_of_zmem_of_ne H5',
        intro h,
        have h1 : k ∈ succ k := zmem_succ,
        rw ← (opair.ext h).1 at h1,
        exact not_zmem_empty h1 },
      have H6'' : ∀ (p q_1 : α), p ∈ k →
        opair p q_1 ∈ erase A' (opair (succ k) (sUnion q)) →
        opair (succ p) (sUnion q_1) ∈ erase A' (opair (succ k) (sUnion q)),
      { intros p q hp hpq,
        apply zmem_erase_of_zmem_of_ne,
        { exact H6' _ _ (zmem_succ_of_zmem hp) (zmem_of_zmem_erase hpq) },
        { intro h,
          rw succ.ext (opair.ext h).1 at hp,
          exact not_zmem_self hp } },
      have H7'' : opair k q ∈ erase A' (opair (succ k) (sUnion q)),
      { apply zmem_erase_of_zmem_of_ne hq,
        intro h,
        have h1 : k ∈ succ k := zmem_succ,
        rw ← (opair.ext h).1 at h1,
        exact not_zmem_self h1 },
      exact h2 q ⟨erase A' (opair (succ k) (sUnion q)), hk,
        λ p q r hpq hpr, H2' p q r (zmem_of_zmem_erase hpq) (zmem_of_zmem_erase hpr),
        H3'', H4'', H5'', H6'', H7''⟩ } }
end

theorem transitive_closure.aux.iff {w : α} : w ∈ transitive_closure z ↔ ∃ y, w ∈ y ∧ ∃ x, x ∈ (ω:α) ∧
  ∃ (A : α) (H1 : x ∈ (ω:α)) (H2 : ∀ p q r, opair p q ∈ A → opair p r ∈ A → q = r)
  (H3 : ∀ p q, opair p q ∈ A → p ∈ succ x) (H4 : ∀ p, p ∈ x → ∃ q, opair p q ∈ A) (H5 : opair ∅ z ∈ A)
  (H6 : ∀ p q, p ∈ x → opair p q ∈ A → opair (succ p) (sUnion q) ∈ A), opair x y ∈ A :=
begin
  rw [transitive_closure],
  rw [zmem_sUnion_iff_zmem_zmem],
  split; intro h; rcases h with ⟨h1, h2, h3⟩; refine ⟨h1, h2, _⟩;
  rwa [zmem_replacement_iff] <|> rwa [zmem_replacement_iff] at h3;
  { intros A B C hab hac,
    have hab1 := hab,
    rcases hab1 with ⟨_, h, _⟩,
    exact unique_of_exists_unique (transitive_closure.aux _ h) hab hac }
end

variable z

theorem transitive_closure.subset : z ⊆ transitive_closure z :=
λ w hw, transitive_closure.aux.iff.2 ⟨z, hw, ∅, empty_zmem_omega, transitive_closure.aux.empty⟩

instance transitive_closure.is_transitive : is_transitive (transitive_closure z) :=
{ zmem_trans := begin
    intros m n hmn hn,
    rw transitive_closure.aux.iff at hn ⊢,
    rcases hn with ⟨y, hny, k, hk, hn⟩,
    refine ⟨_, zmem_sUnion_iff_zmem_zmem.2 ⟨n, hmn, hny⟩, _, succ_zmem_omega_of_zmem hk, transitive_closure.aux.succ hk hn⟩
  end }

theorem transitive_closure.UMP (w : α) (H : z ⊆ w) [is_transitive w] : transitive_closure z ⊆ w :=
begin
  intros x hx,
  rw [transitive_closure.aux.iff] at hx,
  rcases hx with ⟨y, hxy, k, hk, A, H1, H2, H3, H4, H5, H6, H7⟩,
  revert x y A,
  apply induction _ _ _ k hk,
  { intros x y A hxy H2 H3 H4 H5 H6 H7,
    specialize H2 _ _ _ H7 H5,
    subst H2,
    exact H _ hxy },
  { clear hk H1 k,
    intros k hk ih x y A hxy H2 H3 H4 H5 H6 H7,
    cases H4 _ zmem_succ with q hq,
    have H2subst := H2 _ _ _ H7 (H6 _ _ zmem_succ hq),
    subst H2subst,
    rw zmem_sUnion_iff_zmem_zmem at hxy,
    rcases hxy with ⟨t, hxt, hty⟩,
    have H3' : ∀ (p q_1 : α), opair p q_1 ∈ erase A (opair (succ k) (sUnion q)) → p ∈ succ k,
    { intros p q h,
      have h1 := H3 _ _ (zmem_of_zmem_erase h),
      cases zmem_succ_iff_eq_or_zmem.1 h1 with h3 h3,
      { exfalso, subst h3,
        have h3 := H2 _ _ _ (H6 _ _ zmem_succ hq) (zmem_of_zmem_erase h), subst h3,
        exact ne_of_zmem_erase h rfl },
      { exact h3 } },
    have H4' : ∀ (p : α), p ∈ k → (∃ (q_1 : α), opair p q_1 ∈ erase A (opair (succ k) (sUnion q))),
    { intros p hp,
      cases H4 p (zmem_succ_of_zmem hp) with q hq,
      existsi q,
      apply zmem_erase_of_zmem_of_ne hq,
      intro h,
      rw (opair.ext h).1 at hp,
      exact not_zmem_and_zmem hp zmem_succ },
    have H5' : opair ∅ z ∈ erase A (opair (succ k) (sUnion q)),
    { apply zmem_erase_of_zmem_of_ne H5,
      intro h,
      have h1 : k ∈ succ k := zmem_succ,
      rw ← (opair.ext h).1 at h1,
      exact not_zmem_empty h1 },
    have H6' : ∀ (p q_1 : α), p ∈ k →
      opair p q_1 ∈ erase A (opair (succ k) (sUnion q)) →
      opair (succ p) (sUnion q_1) ∈ erase A (opair (succ k) (sUnion q)),
    { intros p q hp hpq,
      apply zmem_erase_of_zmem_of_ne,
      { exact H6 _ _ (zmem_succ_of_zmem hp) (zmem_of_zmem_erase hpq) },
      { intro h,
        rw succ.ext (opair.ext h).1 at hp,
        exact not_zmem_self hp } },
    have H7' : opair k q ∈ erase A (opair (succ k) (sUnion q)),
    { apply zmem_erase_of_zmem_of_ne hq,
      intro h,
      have h1 : k ∈ succ k := zmem_succ,
      rw ← (opair.ext h).1 at h1,
      exact not_zmem_self h1 },
    specialize ih t q (erase A (opair (succ k) (sUnion q))) hty
      (λ p q r hpq hpr, H2 p q r (zmem_of_zmem_erase hpq) (zmem_of_zmem_erase hpr))
      H3' H4' H5' H6' H7',
    exact is_transitive.zmem_trans _ _ hxt ih }
end

end transitive_closure

def prod_assoc (x y z : α) : α :=
comprehension (prod (prod (prod x y) z) (prod x (prod y z)))
(λ m, ∃ p q r, m = opair (opair (opair p q) r) (opair p (opair q r)))

theorem prod_assoc.dom {x y z : α} : dom (prod_assoc x y z) = prod (prod x y) z :=
begin
  apply is_extensional.ext,
  intro m,
  rw zmem_dom_iff,
  split; intro h,
  { cases h with n h,
    rw [prod_assoc, zmem_comprehension_iff] at h,
    rcases h with ⟨h1, p, q, r, h2⟩,
    exact zmem_left_of_zmem_prod h1 },
  { rw [prod, zmem_comprehension_iff] at h,
    rcases h with ⟨_, pq, r, hpq, hr, h⟩,
    subst h,
    rw zmem_comprehension_iff at hpq,
    rcases hpq with ⟨_, p, q, hp, hq, hpq⟩,
    subst hpq,
    existsi opair p (opair q r),
    rw [prod_assoc, zmem_comprehension_iff],
    refine ⟨zmem_prod
        (zmem_prod (zmem_prod hp hq) hr)
        (zmem_prod hp (zmem_prod hq hr)),
      _, _, _, rfl⟩ }
end

theorem prod_assoc.range {x y z : α} : range (prod_assoc x y z) = prod x (prod y z) :=
begin
  apply is_extensional.ext,
  intro m,
  rw zmem_range_iff,
  split; intro h,
  { cases h with n h,
    rw [prod_assoc, zmem_comprehension_iff] at h,
    rcases h with ⟨h1, p, q, r, h2⟩,
    exact zmem_right_of_zmem_prod h1 },
  { rw [prod, zmem_comprehension_iff] at h,
    rcases h with ⟨_, p, qr, hp, hqr, h⟩,
    subst h,
    rw zmem_comprehension_iff at hqr,
    rcases hqr with ⟨_, q, r, hq, hr, hqr⟩,
    subst hqr,
    existsi opair (opair p q) r,
    rw [prod_assoc, zmem_comprehension_iff],
    refine ⟨zmem_prod
        (zmem_prod (zmem_prod hp hq) hr)
        (zmem_prod hp (zmem_prod hq hr)),
      _, _, _, rfl⟩ }
end

instance prod_assoc.is_injective {x y z : α} : is_injective (prod_assoc x y z) :=
{ eq_opair_of_zmem := begin
    intros m h,
    rw [prod_assoc, zmem_comprehension_iff] at h,
    rcases h with ⟨h1, p, q, r, h2⟩,
    exact ⟨_, _, h2⟩
  end,
  exists_unique := begin
    intros m h,
    rw zmem_dom_iff at h,
    cases h with n hn,
    existsi n, split, exact hn,
    intros n' hn',
    rw [prod_assoc, zmem_comprehension_iff] at hn,
    rcases hn with ⟨h1, p, q, r, h2⟩,
    rw [prod_assoc, zmem_comprehension_iff] at hn',
    rcases hn' with ⟨h1', p', q', r', h2'⟩,
    rw opair.iff at h2 h2',
    cases h2 with h2 h3,
    cases h2' with h2' h3',
    subst h2, subst h3, subst h3',
    rw [opair.iff, opair.iff] at h2',
    cases h2' with hpq hr,
    cases hpq with hp hq,
    subst hp, subst hq, subst hr
  end,
  injective := begin
    intros m m' n hm hm',
    rw [prod_assoc, zmem_comprehension_iff] at hm,
    rcases hm with ⟨h1, p, q, r, h2⟩,
    rw [prod_assoc, zmem_comprehension_iff] at hm',
    rcases hm' with ⟨h1', p', q', r', h2'⟩,
    rw opair.iff at h2 h2',
    cases h2 with h2 h3,
    cases h2' with h2' h3',
    subst h2, subst h2', subst h3,
    rw [opair.iff, opair.iff] at h3',
    rcases h3' with ⟨hp, hq, hr⟩,
    subst hp, subst hq, subst hr
  end }

def hom (x y : α) : α :=
comprehension (powerset $ prod x y) (λ f, is_function f ∧ dom f = x)

theorem zmem_hom_iff {f : α} : f ∈ hom x y ↔ is_function f ∧ dom f = x ∧ range f ⊆ y :=
begin
  rw [hom, zmem_comprehension_iff, zmem_powerset],
  split; intro hf; rcases hf with ⟨hf1, hf2, hf3⟩,
  { refine ⟨hf2, hf3, _⟩,
    intros z hz,
    rw zmem_range_iff at hz,
    cases hz with w hwz,
    exact zmem_right_of_zmem_prod (hf1 _ hwz) },
  { refine ⟨_, hf1, hf2⟩,
    intros z hz,
    have hf4 := hf1.eq_opair_of_zmem,
    specialize hf4 _ hz,
    rcases hf4 with ⟨m, n, hf4⟩,
    subst hf4,
    have hf4 : m ∈ dom f,
    { rw zmem_dom_iff, exact ⟨_, hz⟩ },
    have hf5 : n ∈ range f,
    { rw zmem_range_iff, exact ⟨_, hz⟩ },
    rw hf2 at hf4,
    replace hf5 := hf3 _ hf5,
    exact zmem_prod hf4 hf5 }
end

def prod_adjoint_hom (x y z : α) : α :=
comprehension (prod (hom (prod x y) z) (hom x (hom y z)))
(λ m, ∃ (f g : α) (H : m = opair f g),
   ∀ p h, opair p h ∈ g → ∀ q r, opair (opair p q) r ∈ f → opair q r ∈ h)

theorem prod_adjoint_hom.dom {x y z : α} : dom (prod_adjoint_hom x y z) = hom (prod x y) z :=
begin
  apply is_extensional.ext,
  intro m,
  rw zmem_dom_iff,
  split; intro h,
  { cases h with n h,
    rw [prod_adjoint_hom, zmem_comprehension_iff] at h,
    rcases h with ⟨h1, p, q, r, h2⟩,
    exact zmem_left_of_zmem_prod h1 },
  { have h := h,
    rw zmem_hom_iff at h,
    rcases h with ⟨h1, h2, h3⟩,
    let m' : α := comprehension (prod x (hom y z))
      (λ n, ∀ p g, n = opair p g → ∀ q r, opair q r ∈ g → opair (opair p q) r ∈ m),
    have h1' : is_function m',
    { split,
      { intros z hz,
        rw [zmem_comprehension_iff, prod, zmem_comprehension_iff] at hz,
        rcases hz.1.2 with ⟨_, _, _, _, hz1⟩,
        exact ⟨_, _, hz1⟩ },
      { intros x' hx',
        rw [zmem_dom_iff] at hx',
        cases hx' with y' hy',
        existsi y',
        split,
        { exact hy' },
        { intros y'' hy'',
          rw [zmem_comprehension_iff, prod, zmem_comprehension_iff] at hy',
          rcases hy' with ⟨hy1', hy2'⟩,
          rcases hy1' with ⟨_, p', q', hp', hq', h'⟩,
          rcases opair.ext h' with ⟨h1', h2'⟩,
          subst h1', subst h2', clear h',
          rw zmem_hom_iff at hq',
          rcases hq' with ⟨hy1', hy3', hy4'⟩,
          cases hy1' with hy5' hy6',
          specialize hy2' _ _ rfl,
          rw [zmem_comprehension_iff, prod, zmem_comprehension_iff] at hy'',
          rcases hy'' with ⟨hy1'', hy2''⟩,
          rcases hy1'' with ⟨_, p'', q'', hp'', hq'', h''⟩,
          rcases opair.ext h'' with ⟨h1'', h2''⟩,
          subst h1'', subst h2'', clear h'',
          rw zmem_hom_iff at hq'',
          rcases hq'' with ⟨hy1'', hy3'', hy4''⟩,
          cases hy1'' with hy5'' hy6'',
          specialize hy2'' _ _ rfl,
          apply is_extensional.ext,
          intro z',
          cases h1 with h4 h5,
          split; intro hz',
          { specialize hy5'' _ hz',
            rcases hy5'' with ⟨q'', r'', h⟩, subst h,
            specialize hy2'' _ _ hz',
            have hz1' : q'' ∈ dom y'',
            { rw zmem_dom_iff, exact ⟨_, hz'⟩ },
            rw [hy3'', ← hy3'] at hz1',
            specialize hy6' _ hz1',
            rcases hy6' with ⟨r', hy6', _⟩,
            specialize hy2' _ _ hy6',
            have hz2' : opair x' q'' ∈ dom m,
            { rw zmem_dom_iff, exact ⟨_, hy2'⟩ },
            specialize h5 _ hz2',
            replace h5 := unique_of_exists_unique h5 hy2'' hy2',
            subst h5, exact hy6' },
          { specialize hy5' _ hz',
            rcases hy5' with ⟨q', r', h⟩, subst h,
            specialize hy2' _ _ hz',
            have hz1' : q' ∈ dom y',
            { rw zmem_dom_iff, exact ⟨_, hz'⟩ },
            rw [hy3', ← hy3''] at hz1',
            specialize hy6'' _ hz1',
            rcases hy6'' with ⟨r'', hy6'', _⟩,
            specialize hy2'' _ _ hy6'',
            have hz2' : opair x' q' ∈ dom m,
            { rw zmem_dom_iff, exact ⟨_, hy2'⟩ },
            specialize h5 _ hz2',
            replace h5 := unique_of_exists_unique h5 hy2'' hy2',
            subst h5, exact hy6'' } } } },
    have h2' : dom m' = x,
    { apply is_extensional.ext,
      intro p, rw [zmem_dom_iff],
      split; intro hp,
      { cases hp with g hg,
        rw [zmem_comprehension_iff] at hg,
        exact zmem_left_of_zmem_prod hg.1 },
      { let g : α := comprehension (prod y z)
          (λ n, ∀ q r, n = opair q r → opair (opair p q) r ∈ m),
        cases h1 with h4 h5,
        have hg1 : is_function g,
        { split,
          { intros z hz,
            rw [zmem_comprehension_iff, prod, zmem_comprehension_iff] at hz,
            rcases hz.1.2 with ⟨_, _, _, _, hz1⟩,
            exact ⟨_, _, hz1⟩ },
          { intros q hq,
            rw zmem_dom_iff at hq,
            cases hq with r hr,
            existsi r,
            split,
            { exact hr },
            { intros r' hr',
              rw [zmem_comprehension_iff] at hr hr',
              rw h2 at h5,
              specialize h5 _ (zmem_prod hp $ zmem_left_of_zmem_prod hr.1),
              exact unique_of_exists_unique h5 (hr'.2 _ _ rfl) (hr.2 _ _ rfl) } } },
        have hg2 : dom g = y,
        { apply is_extensional.ext,
          intro q,
          rw zmem_dom_iff,
          split; intro hq,
          { cases hq with r hr,
            rw [zmem_comprehension_iff] at hr,
            exact zmem_left_of_zmem_prod hr.1 },
          { have h6 : opair p q ∈ dom m,
            { rw h2, exact zmem_prod hp hq },
            specialize h5 _ h6,
            rcases h5 with ⟨r, hr1, hr2⟩,
            have hr : r ∈ z,
            { apply h3,
              rw zmem_range_iff,
              exact ⟨_, hr1⟩ },
            existsi r,
            rw zmem_comprehension_iff,
            split,
            { exact zmem_prod hq hr },
            { intros _ _ hqr,
              cases opair.ext hqr with hqr1 hqr2,
              subst hqr1, subst hqr2, clear hqr,
              exact hr1 } } },
        have hg3 : range g ⊆ z,
        { intros r hr,
          rw zmem_range_iff at hr,
          cases hr with q hq,
          rw zmem_comprehension_iff at hq,
          exact zmem_right_of_zmem_prod hq.1 },
        existsi g,
        rw zmem_comprehension_iff,
        split,
        { apply zmem_prod hp,
          rw zmem_hom_iff,
          exact ⟨hg1, hg2, hg3⟩ },
        { intros _ _ hpg,
          cases opair.ext hpg with hpg1 hpg2,
          subst hpg1, subst hpg2, clear hpg,
          intros q r hqr,
          rw zmem_comprehension_iff at hqr,
          exact hqr.2 _ _ rfl } } },
    have h3' : range m' ⊆ hom y z,
    { intros g hg,
      rw zmem_range_iff at hg,
      cases hg with p hg,
      rw zmem_comprehension_iff at hg,
      exact zmem_right_of_zmem_prod hg.1 },
    existsi m',
    rw [prod_adjoint_hom, zmem_comprehension_iff],
    split,
    { apply zmem_prod h,
      rw zmem_hom_iff,
      exact ⟨h1', h2', h3'⟩ },
    { refine ⟨_, _, rfl, _⟩,
      intros p g hp q r hpqr,
      rw zmem_comprehension_iff at hp,
      have hg := zmem_right_of_zmem_prod hp.1,
      rw zmem_hom_iff at hg,
      rcases hg with ⟨hg1, hg2, hg3⟩,
      cases hg1 with hg4 hg5,
      rw hg2 at hg5,
      have hpq : opair p q ∈ prod x y,
      { rw [← h2, zmem_dom_iff],
        exact ⟨_, hpqr⟩ },
      specialize hg5 _ (zmem_right_of_zmem_prod hpq),
      rcases hg5 with ⟨r', hr1', hr2'⟩,
      have hpqr' := hp.2 _ _ rfl _ _ hr1',
      cases h1 with h4 h5,
      rw h2 at h5,
      replace h5 := unique_of_exists_unique (h5 _ hpq) hpqr' hpqr,
      subst h5,
      exact hr1' } }
end

theorem prod_adjoint_hom.range {x y z : α} : range (prod_adjoint_hom x y z) = hom x (hom y z) := sorry

instance prod_adjoint_hom.is_injective {x y z : α} : is_injective (prod_adjoint_hom x y z) := sorry

-- maximum usability
theorem prod_adjoint_hom.prop {x y z f g p q : α}
  [is_function f] [is_function g]
  (H1 : f ∈ dom (prod_adjoint_hom x y z))
  (H2 : eval (prod_adjoint_hom x y z) f = g)
  (H3 : opair p q ∈ dom f)
  (H4 : p ∈ dom g) (H5 : q ∈ dom (eval g p))
  [is_function (eval g p)] :
  eval f (opair p q) = eval (eval g p) q := sorry

end zf

end zfc


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import algebra.category.Ring.basic
import algebra.ring.boolean_ring
import order.category.BoolAlg

/-!
# The category of Boolean rings

This file defines `BoolRing`, the category of Boolean rings.

## TODO

Finish the equivalence with `BoolAlg`.
-/

universes u

open category_theory order

/-- The category of Boolean rings. -/
def BoolRing := bundled boolean_ring

namespace BoolRing

instance : has_coe_to_sort BoolRing Type* := bundled.has_coe_to_sort
instance (X : BoolRing) : boolean_ring X := X.str

/-- Construct a bundled `BoolRing` from a `boolean_ring`. -/
def of (α : Type*) [boolean_ring α] : BoolRing := bundled.of α

@[simp] lemma coe_of (α : Type*) [boolean_ring α] : ↥(of α) = α := rfl

instance : inhabited BoolRing := ⟨of punit⟩

instance : bundled_hom.parent_projection @boolean_ring.to_comm_ring := ⟨⟩

attribute [derive [large_category, concrete_category]] BoolRing

@[simps] instance has_forget_to_CommRing : has_forget₂ BoolRing CommRing := bundled_hom.forget₂ _ _

/-- Constructs an isomorphism of Boolean rings from a ring isomorphism between them. -/
@[simps] def iso.mk {α β : BoolRing.{u}} (e : α ≃+* β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

end BoolRing

/-! ### Equivalence between `BoolAlg` and `BoolRing` -/

@[simps] instance BoolRing.has_forget_to_BoolAlg : has_forget₂ BoolRing BoolAlg :=
{ forget₂ := { obj := λ X, BoolAlg.of (as_boolalg X), map := λ X Y, ring_hom.as_boolalg } }

@[simps] instance BoolAlg.has_forget_to_BoolRing : has_forget₂ BoolAlg BoolRing :=
{ forget₂ := { obj := λ X, BoolRing.of (as_boolring X),
               map := λ X Y, bounded_lattice_hom.as_boolring } }


import tactic

namespace hidden₂

  inductive simple_type
  | natural : simple_type
  | arrow : simple_type → simple_type → simple_type

  local notation `𝕆` := simple_type.natural
  local infixr `↣` : 50 := simple_type.arrow
  local notation `𝕋` := simple_type

  @[simp]
  def simple_type.interpret : simple_type → Type
  | simple_type.natural := ℕ
  | (simple_type.arrow σ τ) := σ.interpret → τ.interpret

  local notation `∥` σ `∥` := σ.interpret

  lemma simple_type.arrow_interpret_fun {σ τ : 𝕋} : ∥σ ↣ τ∥ = (∥σ∥ → ∥τ∥) := by simp

  inductive term : 𝕋 → Type
  | zero : term 𝕆
  | K {σ τ : 𝕋} : term $ σ ↣ τ ↣ σ
  | S {σ τ ρ : 𝕋} : term $ (σ ↣ τ ↣ ρ) ↣ (σ ↣ τ) ↣ σ ↣ ρ
  | R {σ : 𝕋} : term $ 𝕆 ↣ σ ↣ (𝕆 ↣ σ ↣ σ) ↣ σ
  | app {σ τ : 𝕋} : term (σ ↣ τ) → term σ → term τ

  def recursor {α : Type} : ℕ → α → (ℕ → α → α) → α
  | 0 y _ := y
  | (n + 1) y x := x n (recursor n y x)

  def term.interpret : Π {σ : 𝕋}, term σ → ∥σ∥
  | _ term.zero := (0 : ℕ)
  | _ (@term.K σ τ) := λ (x) (y), x
  | _ (@term.S σ τ ρ) := λ x y z, x z (y z)
  | _ (@term.R σ) := λ n x₀ x, nat.rec_on n x₀ x
  | τ (@term.app σ .(τ) f x) := f.interpret x.interpret

  inductive type
  | simple : 𝕋 → type
  | pi {σ : 𝕋} : (∥σ∥ → type) → type

  def type.interpret : type → Type
  | (type.simple σ) := ∥σ∥
  | (@type.pi σ τ) := Π x : ∥σ∥, ∥τ x∥

  def howard_simple : Π {σ : 𝕋}, ∥σ∥ → ∥σ∥ → Prop
  | 𝕆 x y := nat.le x y
  | (σ ↣ τ) x y := ∀ z₁ z₂ : ∥σ∥, howard_simple z₁ z₂ → howard_simple (x z₁) (x z₂)

  inductive howard_aux : Π {σ : type} {β : ∥σ∥ → type} {a₁ a₂ : ∥σ∥}, ∥β a₁∥ → ∥β a₂∥ → Prop
  | of_pi {σ : 𝕋} {β : ∥σ∥ → type} (x y : ∥type.pi β∥) :
    (∀ z₁ z₂ : ∥σ∥, howard_simple z₁ z₂ → @howard_aux (type.simple σ) β z₁ z₂ (x z₁) (y z₂)) →
    @howard_aux (@type.pi σ β) _ x y x y

end hidden₂

namespace hidden₁

  def typeof {α : Type} (x : α) := α

  def K {α β : Type} : α → β → α :=
    λ x y, x

  def S  {α β γ : Type} : ((α → β → γ) → (α → β) → α → γ) :=
    (λ x y z, x z (y z))

  def R {α : Type} : ℕ → α → (α → ℕ → α) → α
  | 0 y _ := y
  | (n + 1) y x := x (R n y x) n

  -- Godel primitive recursive functionals
  inductive gpr : Π {α : Type}, α → Type 1
  | natural (n : ℕ) : gpr n
  | K {α β : Type} : @gpr (α → β → α) K
  | S {α β γ : Type} : @gpr ((α → β → γ) → (α → β) → α → γ) S
  | R {α : Type} : @gpr (ℕ → α → (α → ℕ → α) → α) R
  -- the `id` bug
  | app {α β : Type 0} {f : α → β} {x : α} : @gpr (α → β) f → gpr x → gpr ((id f) x)

  -- which to chose?
  -- the Σ-version will cause universe issues, can we work around?
  def godel_primitive_recursive₁ (α : Type) := {f : α // nonempty $ gpr f}
  def godel_primitive_recursive₂ (α : Type) := Σ f : α, gpr f

  @[reducible, simp] def gpr.app' {α β : Type} {f : α → β} {x : α} : gpr f → gpr x → gpr (f x) := by {
    intros h₁ h₂,
    apply gpr.app,
    { exact h₁},
    { exact h₂},
  }

  @[reducible, simp] def I {α : Type} : α → α :=
    S K (@K _ unit)

  example {α : Type} : @I α = @id α := by ext; simp [S, K]

  example : gpr (@I ℕ) :=
  begin
    simp [I],
    repeat  {apply gpr.app' };
    constructor,
  end

  example : ∀ {α : Type}, gpr (@id α) :=
  begin
    intros α,
    have h₁ : @I α = @id α := by ext; simp [S, K],
    have h₂ : gpr (@I α) := by {
      simp only [I],
      repeat { apply gpr.app' };
      constructor,
    },
    rw h₁ at h₂,
    exact h₂,
  end

  #check godel_primitive_recursive₁
  inductive simple_type : Type → Type 1
  | natural : simple_type ℕ
  | function {α β} : simple_type α → simple_type β → simple_type (godel_primitive_recursive₁ $ α → β)

  inductive type : Type → Type 1
  | natural : type ℕ
  | function {α β} : type α → type β → type (godel_primitive_recursive₁ $ α → β)
  | pi {α : Type} {β : α → Type} : simple_type α → (Π a : α, type (β a)) → type (Π a : α, β a)

  def howard_simple : Π {α : Type}, simple_type α → α → α → Prop
  | _ (simple_type.natural) x y := nat.le x y
  | _ (@simple_type.function α β hα hβ) x y :=
    ∀ z₁ z₂ : α, howard_simple hα z₁ z₁ → howard_simple hβ (x.1 z₁) (y.1 z₂)

  inductive howard_aux : Π {α : Type} {β : α → Type} {a₁ a₂ : α}, β a₁ → β a₂ → Prop
  | pi {α : Type} {β : α → Type} {hα : simple_type α} (x y : Π a : α, β a) :
    (∀ z₁ z₂ : α, howard_simple hα z₁ z₂ → howard_aux (x z₁) (y z₂)) →
    @howard_aux (Π a : α, β a) (λ _, (Π a : α, β a)) x y x y

  def howard : Π {α : Type}, type α → α → α → Prop
  | _ type.natural x y := nat.le x y
  | _ (@type.function α β hα hβ) x y := ∀ z₁ z₂ : α, howard hα z₁ z₂ → howard hβ (x.1 z₁) (y.1 z₂)
  | _ (@type.pi α β hα hβ) x y := @howard_aux (Π a : α, β a) (λ _, (Π a : α, β a)) x y x y

end hidden₁