/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl

! This file was ported from Lean 3 source module logic.relator
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Basic

/-!
# Relator for functions, pairs, sums, and lists.

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/

namespace Relator

universe u₁ u₂ v₁ v₂

/- TODO(johoelzl):
 * should we introduce relators of datatypes as recursive function or as inductive
predicate? For now we stick to the recursor approach.
 * relation lift for datatypes, Π, Σ, set, and subtype types
 * proof composition and identity laws
 * implement method to derive relators from datatype
-/
section

variable {α : Sort u₁} {β : Sort u₂} {γ : Sort v₁} {δ : Sort v₂}

variable (R : α → β → Prop) (S : γ → δ → Prop)

#print Relator.LiftFun /-
def LiftFun (f : α → γ) (g : β → δ) : Prop :=
  ∀ ⦃a b⦄, R a b → S (f a) (g b)
#align relator.lift_fun Relator.LiftFun
-/

-- mathport name: «expr ⇒ »
infixr:40 " ⇒ " => LiftFun

end

section

variable {α : Type u₁} {β : Type u₂} (R : α → β → Prop)

#print Relator.RightTotal /-
def RightTotal : Prop :=
  ∀ b, ∃ a, R a b
#align relator.right_total Relator.RightTotal
-/

#print Relator.LeftTotal /-
def LeftTotal : Prop :=
  ∀ a, ∃ b, R a b
#align relator.left_total Relator.LeftTotal
-/

#print Relator.BiTotal /-
def BiTotal : Prop :=
  LeftTotal R ∧ RightTotal R
#align relator.bi_total Relator.BiTotal
-/

#print Relator.LeftUnique /-
def LeftUnique : Prop :=
  ∀ ⦃a b c⦄, R a c → R b c → a = b
#align relator.left_unique Relator.LeftUnique
-/

#print Relator.RightUnique /-
def RightUnique : Prop :=
  ∀ ⦃a b c⦄, R a b → R a c → b = c
#align relator.right_unique Relator.RightUnique
-/

#print Relator.BiUnique /-
def BiUnique : Prop :=
  LeftUnique R ∧ RightUnique R
#align relator.bi_unique Relator.BiUnique
-/

variable {R}

/- warning: relator.right_total.rel_forall -> Relator.RightTotal.rel_forall is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u₁}} {β : Type.{u₂}} {R : α -> β -> Prop}, (Relator.RightTotal.{u₁, u₂} α β R) -> (Relator.LiftFun.{max (succ u₁) 1, max (succ u₂) 1, 1, 1} (α -> Prop) (β -> Prop) Prop Prop (Relator.LiftFun.{succ u₁, succ u₂, 1, 1} α β Prop Prop R Implies) Implies (fun (p : α -> Prop) => forall (i : α), p i) (fun (q : β -> Prop) => forall (i : β), q i))
but is expected to have type
  forall {α : Type.{u₁}} {β : Type.{u₂}} {R : α -> β -> Prop}, (Relator.RightTotal.{u₁, u₂} α β R) -> (Relator.LiftFun.{max (succ u₁) (succ u_1), succ u₂, succ (imax (succ u₁) u_1), 1} (α -> Sort.{u_1}) (β -> Prop) Sort.{imax (succ u₁) u_1} Prop (Relator.LiftFun.{succ u₁, succ u₂, succ u_1, 1} α β Sort.{u_1} Prop R (fun (x._@.Mathlib.Logic.Relator._hyg.883 : Sort.{u_1}) (x._@.Mathlib.Logic.Relator._hyg.885 : Prop) => x._@.Mathlib.Logic.Relator._hyg.883 -> x._@.Mathlib.Logic.Relator._hyg.885)) (fun (x._@.Mathlib.Logic.Relator._hyg.896 : Sort.{imax (succ u₁) u_1}) (x._@.Mathlib.Logic.Relator._hyg.898 : Prop) => x._@.Mathlib.Logic.Relator._hyg.896 -> x._@.Mathlib.Logic.Relator._hyg.898) (fun (p : α -> Sort.{u_1}) => forall (i : α), p i) (fun (q : β -> Prop) => forall (i : β), q i))
Case conversion may be inaccurate. Consider using '#align relator.right_total.rel_forall Relator.RightTotal.rel_forallₓ'. -/
theorem RightTotal.rel_forall (h : RightTotal R) :
    ((R ⇒ Implies) ⇒ Implies) (fun p => ∀ i, p i) fun q => ∀ i, q i := fun p q Hrel H b =>
  Exists.elim (h b) fun a Rab => Hrel Rab (H _)
#align relator.right_total.rel_forall Relator.RightTotal.rel_forall

#print Relator.LeftTotal.rel_exists /-
theorem LeftTotal.rel_exists (h : LeftTotal R) :
    ((R ⇒ Implies) ⇒ Implies) (fun p => ∃ i, p i) fun q => ∃ i, q i := fun p q Hrel ⟨a, pa⟩ =>
  (h a).imp fun b Rab => Hrel Rab pa
#align relator.left_total.rel_exists Relator.LeftTotal.rel_exists
-/

#print Relator.BiTotal.rel_forall /-
theorem BiTotal.rel_forall (h : BiTotal R) :
    ((R ⇒ Iff) ⇒ Iff) (fun p => ∀ i, p i) fun q => ∀ i, q i := fun p q Hrel =>
  ⟨fun H b => Exists.elim (h.right b) fun a Rab => (Hrel Rab).mp (H _), fun H a =>
    Exists.elim (h.left a) fun b Rab => (Hrel Rab).mpr (H _)⟩
#align relator.bi_total.rel_forall Relator.BiTotal.rel_forall
-/

#print Relator.BiTotal.rel_exists /-
theorem BiTotal.rel_exists (h : BiTotal R) :
    ((R ⇒ Iff) ⇒ Iff) (fun p => ∃ i, p i) fun q => ∃ i, q i := fun p q Hrel =>
  ⟨fun ⟨a, pa⟩ => (h.left a).imp fun b Rab => (Hrel Rab).1 pa, fun ⟨b, qb⟩ =>
    (h.right b).imp fun a Rab => (Hrel Rab).2 qb⟩
#align relator.bi_total.rel_exists Relator.BiTotal.rel_exists
-/

#print Relator.left_unique_of_rel_eq /-
theorem left_unique_of_rel_eq {eq' : β → β → Prop} (he : (R ⇒ R ⇒ Iff) Eq eq') : LeftUnique R :=
  fun a b c (ac : R a c) (bc : R b c) => (he ac bc).mpr ((he bc bc).mp rfl)
#align relator.left_unique_of_rel_eq Relator.left_unique_of_rel_eq
-/

end

#print Relator.rel_imp /-
theorem rel_imp : (Iff ⇒ Iff ⇒ Iff) Implies Implies := fun p q h r s l => imp_congr h l
#align relator.rel_imp Relator.rel_imp
-/

#print Relator.rel_not /-
theorem rel_not : (Iff ⇒ Iff) Not Not := fun p q h => not_congr h
#align relator.rel_not Relator.rel_not
-/

#print Relator.bi_total_eq /-
theorem bi_total_eq {α : Type u₁} : Relator.BiTotal (@Eq α) :=
  { left := fun a => ⟨a, rfl⟩
    right := fun a => ⟨a, rfl⟩ }
#align relator.bi_total_eq Relator.bi_total_eq
-/

variable {α : Type _} {β : Type _} {γ : Type _} {δ : Type _}

variable {r : α → β → Prop} {p : β → γ → Prop} {q : γ → δ → Prop}

/- warning: relator.left_unique.flip -> Relator.LeftUnique.flip is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {r : α -> β -> Prop}, (Relator.LeftUnique.{u1, u2} α β r) -> (Relator.RightUnique.{u2, u1} β α (flip.{succ u1, succ u2, 1} α β Prop r))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {r : α -> β -> Prop}, (Relator.LeftUnique.{u2, u1} α β r) -> (Relator.RightUnique.{u1, u2} β α (flip.{succ u2, succ u1, 1} α β Prop r))
Case conversion may be inaccurate. Consider using '#align relator.left_unique.flip Relator.LeftUnique.flipₓ'. -/
theorem LeftUnique.flip (h : LeftUnique r) : RightUnique (flip r) := fun a b c h₁ h₂ => h h₁ h₂
#align relator.left_unique.flip Relator.LeftUnique.flip

#print Relator.rel_and /-
theorem rel_and : ((· ↔ ·) ⇒ (· ↔ ·) ⇒ (· ↔ ·)) (· ∧ ·) (· ∧ ·) := fun a b h₁ c d h₂ =>
  and_congr h₁ h₂
#align relator.rel_and Relator.rel_and
-/

#print Relator.rel_or /-
theorem rel_or : ((· ↔ ·) ⇒ (· ↔ ·) ⇒ (· ↔ ·)) (· ∨ ·) (· ∨ ·) := fun a b h₁ c d h₂ =>
  or_congr h₁ h₂
#align relator.rel_or Relator.rel_or
-/

#print Relator.rel_iff /-
theorem rel_iff : ((· ↔ ·) ⇒ (· ↔ ·) ⇒ (· ↔ ·)) (· ↔ ·) (· ↔ ·) := fun a b h₁ c d h₂ =>
  iff_congr h₁ h₂
#align relator.rel_iff Relator.rel_iff
-/

/- warning: relator.rel_eq -> Relator.rel_eq is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {r : α -> β -> Prop}, (Relator.BiUnique.{u1, u2} α β r) -> (Relator.LiftFun.{succ u1, succ u2, succ u1, succ u2} α β (α -> Prop) (β -> Prop) r (Relator.LiftFun.{succ u1, succ u2, 1, 1} α β Prop Prop r Iff) (Eq.{succ u1} α) (Eq.{succ u2} β))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {r : α -> β -> Prop}, (Relator.BiUnique.{u2, u1} α β r) -> (Relator.LiftFun.{succ u2, succ u1, succ u2, succ u1} α β (α -> Prop) (β -> Prop) r (Relator.LiftFun.{succ u2, succ u1, 1, 1} α β Prop Prop r (fun (x._@.Mathlib.Logic.Relator._hyg.1983 : Prop) (x._@.Mathlib.Logic.Relator._hyg.1985 : Prop) => Iff x._@.Mathlib.Logic.Relator._hyg.1983 x._@.Mathlib.Logic.Relator._hyg.1985)) (fun (x._@.Mathlib.Logic.Relator._hyg.1998 : α) (x._@.Mathlib.Logic.Relator._hyg.2000 : α) => Eq.{succ u2} α x._@.Mathlib.Logic.Relator._hyg.1998 x._@.Mathlib.Logic.Relator._hyg.2000) (fun (x._@.Mathlib.Logic.Relator._hyg.2013 : β) (x._@.Mathlib.Logic.Relator._hyg.2015 : β) => Eq.{succ u1} β x._@.Mathlib.Logic.Relator._hyg.2013 x._@.Mathlib.Logic.Relator._hyg.2015))
Case conversion may be inaccurate. Consider using '#align relator.rel_eq Relator.rel_eqₓ'. -/
theorem rel_eq {r : α → β → Prop} (hr : BiUnique r) : (r ⇒ r ⇒ (· ↔ ·)) (· = ·) (· = ·) :=
  fun a b h₁ c d h₂ => ⟨fun h => hr.right h₁ <| h.symm ▸ h₂, fun h => hr.left h₁ <| h.symm ▸ h₂⟩
#align relator.rel_eq Relator.rel_eq

end Relator


import data.list
import syntax.syntax
import semantics.semantics syntax.syntaxlemmas
import syntax.soundness order.zorn data.set.basic
local attribute [instance] classical.prop_decidable

open  Kproof

/-

In this file are lemmas related to consitency (we never prove both A and ¬ A).
The most important is Lindenbaum's lemma. Many thanks to the work of Paula
Neeley whose previous work helped me when I was stuck.

-/

def sem_cons (AX : ctx) := ¬ entails AX ⊥
attribute [class] sem_cons

-- Any axiom system that is consistent does not prove false
lemma nprfalse (AX : ctx) (hax : sem_cons AX) : ¬  Kproof AX ⊥ :=
begin
have h1 : ¬ entails AX ⊥ → ¬  Kproof AX ⊥,
{have h2 :  Kproof AX ⊥ → entails AX ⊥, from soundness AX ⊥,
rw ←not_imp_not at h2, exact h2},
apply h1, exact hax
end

lemma prnot_to_notpr (A : form) (AX : ctx) (hax : sem_cons AX) :
   Kproof AX (¬A) → ¬  Kproof AX A :=
begin
intro h1, by_contradiction h2,
exact absurd (mp (mp pl5 contra_equiv_false) (mp (mp pl4 h2) h1)) (nprfalse AX hax)
end

lemma pr_to_notprnot (A : form) (AX : ctx) (hax : sem_cons AX) :
   Kproof AX A → ¬  Kproof AX (¬A) :=
begin
have h1 := prnot_to_notpr A AX hax,
rw ←not_imp_not at h1, intro h2, apply h1, rw not_not, exact h2,
end

-- Finite conjunction of formulas
def fin_conj : list form → form
  | []      := ⊤
  | (A::As) := A & (fin_conj As)

-- A few helper lemmas about finite conjunctions
lemma fin_conj_simp {Γ : ctx} : ∀ B : form,  Kproof Γ (¬fin_conj [B, ¬B]) :=
begin
intro B,
exact (not_and_subst phi_and_true).mpr not_contra
end

lemma imp_conj_imp_imp {Γ : ctx} {A B C : form} {L : list form} :
   Kproof Γ ((fin_conj (A::L)) ⊃ B) ↔  Kproof Γ (fin_conj L ⊃ (A ⊃ B)) :=
begin
split,
intro h, dsimp [fin_conj] at h, rw and_right_imp at h, exact h,
intro h, dsimp [fin_conj], rw and_right_imp, exact h
end

lemma fin_conj_cons_imp {Γ : ctx} {A b : form} {L : list form} :
  Kproof Γ (fin_conj (A::L) ⊃ (A ⊃ b)) →  Kproof Γ (fin_conj L ⊃ (A ⊃ b)) :=
begin
intro h, rw imp_conj_imp_imp at h, rw imp_imp_iff_imp at h, exact h, exact A,
end

lemma fin_conj_append {Γ : ctx} {L L' : list form} :
   Kproof Γ ((fin_conj L' & fin_conj L) ↔ (fin_conj (L' ++ L))) :=
begin
induction L', rw fin_conj,
exact (mp (mp pl4 (cut (mp pl6 and_switch) (mp pl5 phi_and_true)))
  (cut (mp pl6 phi_and_true) (mp pl5 and_switch))),
exact mp (mp pl4 (cut (mp pl5 and_commute) (imp_and_imp (mp pl5 L'_ih))))
  (cut iden (cut (imp_and_imp (mp pl6 L'_ih)) (mp pl6 and_commute)))
end

lemma fin_conj_empty {AX : ctx} {L : list form} (hax : sem_cons AX) :
  L = [] → ¬  Kproof AX (fin_conj L ⊃ ⊥) :=
begin
intro h1, subst h1,
by_contradiction h2,
exact absurd (mp h2 iden) (nprfalse AX hax)
end

lemma fin_conj_repeat_helper {AX : ctx} {θ : form} {L : list form} (hax : sem_cons AX) :
  (∀ B ∈ L, B = θ) →  Kproof AX (θ ⊃ fin_conj L) :=
begin
intros h1, induction L,
exact mp pl1 iden,
simp at *,
cases h1 with h1 h2,
subst h1,
exact cut (mp double_imp pl4) (imp_and_and_imp (mp (mp pl4 iden) (L_ih h2))),
end

lemma fin_conj_repeat {AX : ctx} {A : form} {L : list form} (hax : sem_cons AX) :
  (∀ B ∈ L, B = ¬A) →  Kproof AX (¬fin_conj L) →  Kproof AX A :=
begin
intros h1 h2, induction L,
exact absurd (mp dne h2) (nprfalse AX hax),
simp at *,
cases h1 with h1 h3,
have h5 := contrapos.mpr (fin_conj_repeat_helper hax h3),
subst h1,
exact (mp (mp pl3 (contrapos.mpr (cut h5 dne)))
  (contrapos.mpr (cut ((demorgans.mp) (mp (mp pl6 (iff_not and_switch)) h2)) dne)))
end

lemma fin_conj_box2 {AX : ctx} {A B : form} :  Kproof AX ((□A & □B) ⊃ □(A & B)) :=
begin
exact (mp double_imp (cut2 pl6 (cut pl5 (cut (mp kdist (nec pl4)) kdist))))
end

lemma fin_conj_boxn {AX : ctx} {L : list form} :
   Kproof AX ((fin_conj (list.map □ L)) ⊃ (□(fin_conj L))) :=
begin
induction L,
exact (mp pl1 (nec prtrue)),
exact (cut (imp_and_imp L_ih) fin_conj_box2)
end

lemma listempty {Γ : ctx} {L : list form} :
  (∀ A ∈ L, A ∈ Γ) → Γ = ∅ → L = [] :=
begin
intros h1 h2,
by_contradiction h3,
have h4 := list.length_pos_of_ne_nil,
have h5 := list.exists_mem_of_length_pos,
cases h5 (h4 h3) with A h5,
exact absurd (h1 A h5) (set.eq_empty_iff_forall_not_mem.mp h2 A)
end

-- Consistency for a finite set of formulas L
def fin_ax_consist (AX : ctx) (L : list form) := ¬  Kproof AX (fin_conj L ⊃ ⊥)

-- Consistency for an arbitrary set of formulas Γ
def ax_consist (AX Γ : ctx) :=
  ∀ L : list form, (∀ B ∈ L, B ∈ Γ) → fin_ax_consist AX L

-- Γ is maximally ax-consistent
def max_ax_consist (AX Γ : ctx) :=
  ax_consist AX Γ ∧ (∀ Γ', Γ ⊂ Γ' → ¬ ax_consist AX Γ')

lemma max_imp_ax {AX Γ : ctx} : max_ax_consist AX Γ → ax_consist AX Γ :=
begin
intro h1, exact h1.left
end

lemma five_helper (AX : ctx) :
  ∀ Γ : ctx, ∀ A : form, ∀ L : list form, ∀ b : form,
  (∀ B ∈ L, B ∈ Γ ∨ B = A) →  Kproof AX (fin_conj L ⊃ b) → ∃ L',
  (∀ B ∈ L', B ∈ Γ) ∧  Kproof AX (fin_conj L' ⊃ (A ⊃ b)) :=
begin
intros Γ A L b h1 h2,
revert b,
induction L,
{intros b h2, existsi ([] : list form), split,
intros B h3, exfalso, apply list.not_mem_nil B h3,
exact imp_if_imp_imp h2},
{intros b h2,
have h1a : ∀ (B : form), B ∈ L_tl → B ∈ Γ ∨ B = A,
{intros B h2, apply h1 B (list.mem_cons_of_mem L_hd h2)},
have h1b : L_hd ∈ Γ ∨ L_hd = A,
{apply h1 L_hd, left, refl},
cases h1b,
have h3 := and_right_imp.mp h2,
cases L_ih h1a (L_hd ⊃ b) h3 with L' ih, existsi (L_hd::L' : list form),
cases ih, split, intros B h4, cases h4,
subst h4, exact h1b,
apply ih_left B h4, rw imp_shift at ih_right,
rw ←imp_conj_imp_imp at ih_right, exact ih_right,
have h3 :  Kproof AX (fin_conj (L_hd::L_tl) ⊃ b),
exact h2, exact b,
have h4 := and_right_imp.mp,
have h5 :  Kproof AX (fin_conj L_tl ⊃ (A ⊃ b)),
  from eq.subst h1b (h4 h2),
cases L_ih h1a (A ⊃ b) h5 with L' ih,
existsi (L' : list form), split,
exact ih.left, exact imp_imp_iff_imp.mp ih.right}
end

lemma five (AX : ctx) :
  ∀ Γ : ctx, ∀ A : form, ¬ ax_consist AX (Γ ∪ A) → ∃ L',
  (∀ B ∈ L', B ∈ Γ) ∧  Kproof AX (fin_conj L' ⊃ ¬A) :=
begin
intro Γ, intro A, intro h1, rw ax_consist at h1,
push_neg at h1,
cases h1 with L h1,
have h2 := five_helper AX Γ A L ⊥,
cases h1,
have h3 : (∀ (B : form), B ∈ L → B ∈ Γ ∨ B = A),
{intros B this, exact or.swap (h1_left B this)},
apply h2 h3, rw fin_ax_consist at h1_right, rw not_not at h1_right,
exact h1_right,
end

lemma six_helper (AX Γ : ctx) (h : ax_consist AX Γ) :
max_ax_consist AX Γ → ∀ A : form, A ∈ Γ ∨ (¬A) ∈ Γ :=
begin
intros h1 A, rw or_iff_not_and_not, by_contradiction h2,
cases h2 with h2l h2r,
cases h1 with h1l h1r,
have h2 := h1r (Γ ∪ A), have h3 := h1r (Γ ∪ ¬A),
have h4 : ¬ax_consist AX (Γ ∪ ¬A),
{apply h3, from set.ssubset_insert h2r},
have h5 : ¬ax_consist AX (Γ ∪ A),
{apply h2, from set.ssubset_insert h2l},
clear h2 h3, have h6 := five AX Γ A _, have h7 := five AX Γ (¬A) _,
cases h6 with L' h6, cases h7 with L h7, cases h6 with h6l h6r,
cases h7 with h7l h7r,
have h8 := imp_and_and_imp (mp (mp pl4 h6r) h7r),
have h12 := cut (mp pl6 fin_conj_append) (cut h8 (mp pl5 contra_equiv_false)),
have h13 : (∀ (B : form), B ∈ L' ++ L → B ∈ Γ),
{intros B h13, rw list.mem_append at h13,
cases h13, exact (h6l B) h13, exact (h7l B) h13},
exact absurd h12 ((h1l (L' ++ L)) h13),
exact h4, exact h5
end

lemma six (AX Γ : ctx) (h : ax_consist AX Γ) :
max_ax_consist AX Γ ↔ ∀ A, (A ∈ Γ ∨ (¬A) ∈ Γ) ∧ ¬(A ∈ Γ ∧ (¬A) ∈ Γ) :=
begin
simp, split,
intro h1, intro A,
split, exact six_helper AX Γ h h1 A,
{rw ←not_and, by_contradiction h2,
cases h2 with h2 h3,
specialize h ([A, ¬A]), simp at *,
have h4 : (∀ (B : form), B = A ∨ B = ¬A → B ∈ Γ),
{intros B h4, cases h4, subst h4, exact h2, subst h4, exact h3},

exact absurd (fin_conj_simp A) (h h2 h3)},
intro h1, split, exact h,
intros Γ' h2,
have h3 : Γ ⊆ Γ' ∧ ¬ Γ' ⊆ Γ, from h2,
cases h3,
rw set.not_subset at h3_right,
apply (exists.elim h3_right), simp, intros B h4 h5,
specialize h1 B, cases h1,
cases h1_left,
apply absurd h1_left h5,
have h6 := set.mem_of_subset_of_mem h3_left h1_left,
rw ax_consist,
push_neg,
existsi ([B,¬B] : list form),
simp, split,
apply and.intro,
exact h4,
exact h6,
rw fin_ax_consist, rw not_not,
exact fin_conj_simp B,
end

lemma mini_cons_help {AX Γ : ctx} {A : form} {L L' : list form} :
  (∀ B ∈ L, B ∈ Γ) →  Kproof AX (fin_conj L ⊃ A) → (∀ B ∈ L', B ∈ (insert A Γ))
  → ∃ L'' : list form, (∀ B ∈ L'', B ∈ Γ) ∧  Kproof AX (fin_conj L'' ⊃ fin_conj L') :=
begin
intros h1 h2 h3, induction L',
existsi ([] : list form),
split,
intros B h4, exact false.elim h4,
exact iden,
simp at *,
cases h3 with h3 h4,
cases L'_ih h4 with L'' L'_ih,
cases L'_ih with ih1 ih2,
cases h3,
existsi (L''++L : list form),
split,
simp at *, intros B h2,
cases h2 with h2 h5,
exact ih1 B h2,
exact h1 B h5,
subst h3,
exact (cut (mp pl6 fin_conj_append) (cut (mp pl5 and_switch) (imp_and_and_imp (mp (mp pl4 h2) ih2)))),
existsi (L'_hd::L'' : list form),
split, simp at *, split, exact h3, exact ih1,
exact imp_and_imp ih2
end

lemma mini_cons {AX Γ : ctx} {A : form} {L : list form} :
  max_ax_consist AX Γ → (∀ B ∈ L, B ∈ Γ) →  Kproof AX (fin_conj L ⊃ A) → A ∈ Γ :=
begin
intros h1 h2 h3,
by_contradiction h4,
cases h1 with h1 h5,
specialize h5 (Γ ∪ {A}),
simp at h5,
specialize h5 (set.ssubset_insert h4),
rw ax_consist at h5,
push_neg at h5,
cases h5 with L' h5,
cases h5 with h5 h6,
rw fin_ax_consist at h6,
rw not_not at h6,
have h7 := mini_cons_help h2 h3 h5,
cases h7 with L'' h7,
cases h7 with h7 h8,
apply h1 L'' h7,
exact cut h8 h6
end

lemma max_dn (AX Γ : ctx) (h : max_ax_consist AX Γ) (A : form) :
  A ∈ Γ ↔ (¬¬A) ∈ Γ :=
begin
split, intro h1,
have h2 : (∀ B ∈ [A], B ∈ Γ) →  Kproof AX (fin_conj [A] ⊃ (¬¬A)) → (¬¬A) ∈ Γ, from mini_cons h,
simp at *, apply h2, exact h1,
exact (cut (mp pl5 phi_and_true) dni),
intro h1,
have h2 : (∀ B ∈ [¬¬A], B ∈ Γ) →  Kproof AX (fin_conj [¬¬A] ⊃ A) → A ∈ Γ, from mini_cons h,
simp at *, apply h2, exact h1,
exact (cut (mp pl5 phi_and_true) dne),
end

lemma max_boxdn (AX Γ : ctx) (h : max_ax_consist AX Γ) (A : form) :
  (¬□A) ∈ Γ → (¬□(¬¬A)) ∈ Γ :=
begin
intro h1,
have h2 : (∀ B ∈ [(¬□A)], B ∈ Γ) →  Kproof AX (fin_conj [(¬□A)] ⊃ (¬□(¬¬A))) → (¬□(¬¬A)) ∈ Γ,
  from mini_cons h,
simp at *, apply h2, exact h1, clear h2,
exact (cut (mp pl5 phi_and_true) (mp pl5 box_dn)),
end

lemma max_notiff (AX Γ : ctx) (h : max_ax_consist AX Γ) (A : form) :
  A ∉ Γ ↔ (¬A) ∈ Γ :=
begin
split, intro h1,
have h2 := max_imp_ax h,
have h3 := six_helper AX Γ h2 h,
specialize h3 A, cases h3, exact absurd h3 h1, exact h3,
intro h1,
have h2 := max_imp_ax h,
have h3 := six AX Γ h2,
cases h3, specialize h3_mp h (¬A), simp at *,
cases h3_mp with mp1 mp2,
have h4 := max_dn AX Γ h A,
rw ←not_iff_not at h4, apply h4.mpr, exact mp2 h1
end

lemma max_imp_1 {AX Γ : ctx} {A B : form} :
  max_ax_consist AX Γ → (A ∈ Γ → B ∈ Γ) → (A ⊃ B) ∈ Γ :=
begin
intros h1 h2, rw imp_iff_not_or at h2,
cases h2,
have h3 : (∀ C ∈ [¬A], C ∈ Γ) →  Kproof AX (fin_conj [¬A] ⊃ (A ⊃ B)) → (A ⊃ B) ∈ Γ, from mini_cons h1,
simp at *, apply h3,
exact (max_notiff AX Γ h1 A).mp h2,
exact cut (mp pl5 phi_and_true) (and_right_imp.mp exfalso),
have h3 : (∀ C ∈ [B], C ∈ Γ) →  Kproof AX (fin_conj [B] ⊃ (A ⊃ B)) → (A ⊃ B) ∈ Γ, from mini_cons h1,
simp at *,
apply h3, exact h2, exact (cut (mp pl5 phi_and_true) pl1),
end

lemma max_imp_2 {AX Γ : ctx} {A B : form} :
  max_ax_consist AX Γ → (A ⊃ B) ∈ Γ → A ∈ Γ → B ∈ Γ :=
begin
intros h1 h2 h3,
have h4 : (∀ C ∈ [A, (A ⊃ B)], C ∈ Γ) →  Kproof AX (fin_conj [A, (A ⊃ B)] ⊃ B) → B ∈ Γ, from mini_cons h1,
simp at *, apply h4,
exact h3,
exact h2,
exact and_right_imp.mpr (mp pl5 phi_and_true),
end

lemma max_conj_1 {AX Γ : ctx} {A B : form} :
  max_ax_consist AX Γ → (A ∈ Γ ∧ B ∈ Γ) → (A & B) ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ C ∈ [A], C ∈ Γ) →  Kproof AX (fin_conj [A] ⊃ (B ⊃ (A & B))) → (B ⊃ (A & B)) ∈ Γ,
  from mini_cons h1,
simp at *,
apply max_imp_2 h1,
exact h3 h2.left (cut (mp pl5 phi_and_true) pl4), exact h2.right
end

lemma max_conj_2 {AX Γ : ctx} {A B : form} :
  max_ax_consist AX Γ → (A & B) ∈ Γ → A ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ C ∈ [(A & B)], C ∈ Γ) →  Kproof AX (fin_conj [(A & B)] ⊃ A) → A ∈ Γ,
  from mini_cons h1,
simp at *, apply h3, exact h2,
exact (cut (mp pl5 phi_and_true) pl5)
end

lemma max_conj_3 {AX Γ : ctx} {A B : form} :
  max_ax_consist AX Γ → (A & B) ∈ Γ → B ∈ Γ :=
begin
intros h1 h2,
have h3 : (∀ C ∈ [(A & B)], C ∈ Γ) →  Kproof AX (fin_conj [(A & B)] ⊃ B) → B ∈ Γ,
  from mini_cons h1,
simp at *, apply h3, exact h2,
exact (cut (mp pl5 phi_and_true) pl6)
end

lemma max_equiv (AX Γ : ctx) : max_ax_consist AX Γ ↔ ax_consist AX Γ ∧
  ∀ Γ', ax_consist AX Γ' → Γ ⊆ Γ' → Γ = Γ' :=
begin
split,
{intro h1, split, exact h1.left,
intros Γ' h2 h3, rw set.subset.antisymm_iff, split, exact h3,
by_contradiction h4,
exact h1.right Γ' (and.intro h3 h4) h2},
intro h1, split, exact h1.left,
intros Γ' h2, by_contradiction h3,
rw set.ssubset_def at h2, apply h2.right,
rw h1.right Γ' h3 h2.left,
end

open zorn
-- Lemma: if c is a chain of sets, L is a list of elements such that
-- every element in L is in Union(c), then there is an element m in c such that every
-- element of L is in m.
lemma lindenhelper (c : set ctx) (h : c.nonempty) (h1 : chain (⊆) c) (L : list form) :
(∀ A ∈ L, A ∈ ⋃₀(c)) → ∃ m ∈ c, (∀ B ∈ L, B ∈ m) :=
begin
intro h2,
induction L, simp,
exact h,
have h2b : ∀ A, A ∈ L_tl → A ∈ ⋃₀(c),
{intros A h3, apply h2, exact set.mem_union_right (eq A) h3},
cases L_ih h2b with m ih,
cases ih with h3 ih,
specialize h2 L_hd,
simp at h2,
cases h2 with m' h2,
cases h2 with h2 h4,
existsi (m' ∪ m : ctx),
have h5 : m' ∪ m ∈ c,
{have h6 := chain.total_of_refl h1 h3 h2,
cases h6,
exact (eq.substr (set.union_eq_self_of_subset_right h6) h2),
exact (eq.substr (set.union_eq_self_of_subset_left h6) h3)},
existsi (h5 : m' ∪ m ∈ c),
intros B h6, cases h6,
subst h6, exact set.mem_union_left m h4,
exact set.mem_union_right m' (ih B h6)
end

lemma lindenbaum (AX Γ : ctx) (hax : ax_consist AX Γ) :
  ∃ Γ', max_ax_consist AX Γ' ∧ Γ ⊆ Γ' :=
begin
let P := { Γ'' | Γ'' ⊇ Γ ∧ ax_consist AX Γ''},
have h : ∀ c ⊆ P, chain (⊆) c → c.nonempty → ∃ub ∈ P, ∀ s ∈ c, s ⊆ ub,
{intros c h2 h3 h4, use ⋃₀(c),
have h5 := lindenhelper c h4 h3,
repeat {split},
cases h4 with Γ'' h4,
have h6 := set.mem_of_mem_of_subset h4 h2,
cases h6 with h6 h7,
apply set.subset_sUnion_of_subset c Γ'' h6 h4,
intros L h6,
cases h5 L h6 with m h5,
cases h5 with h7 h5,
cases (set.mem_of_mem_of_subset h7 h2) with h8 h9,
apply h9, exact h5,
intros s h7, exact set.subset_sUnion_of_mem h7},
have h1 : Γ ∈ P,
split,
exact set.subset.rfl,
exact hax,
cases zorn_subset_nonempty P h Γ h1 with Γ' h2,
cases h2 with h2 h3,
cases h3 with h3 h4,
use Γ', split, rw max_equiv, split, apply h2.2,
intros m h5 h6, symmetry, apply h4 m, split,
apply set.subset.trans h2.1 h6,
exact h5, exact h6, apply h2.1
end

lemma max_ax_exists (AX : ctx) (hax : sem_cons AX) : ∃ Γ : ctx, max_ax_consist AX Γ :=
begin
have h1 : ax_consist AX ∅,
{intro L, intro h2, rw fin_ax_consist,
have h3 := listempty h2, have this : ∅ = ∅, refl,
specialize h3 this, subst h3, by_contradiction h4,
apply nprfalse AX hax, exact mp dne h4},
have h2 := lindenbaum AX ∅ h1,
cases h2 with Γ h2, cases h2 with h2 h3, existsi (Γ : ctx), apply h2
end


lemma succ_mul (a b : mynat) : succ a * b = a * b + b :=
begin
induction b with k Pk,
repeat { rw mul_zero },
rw add_zero,
refl,
repeat { rw mul_succ },
rw Pk,
repeat { rw add_succ },
rw add_right_comm,
refl,

end


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.Init.Data.Bool.Basic
import Mathlib.Init.Logic
import Mathlib.Tactic.Coe

/-!
# Lemmas about booleans

These are the lemmas about booleans which were present in core Lean 3. See also
the file Mathlib.Data.Bool.Basic which contains lemmas about booleans from
mathlib 3.

-/

-- We align Lean 3 lemmas with lemmas in `Init.SimpLemmas` in Lean 4.
#align band_self Bool.and_self
#align band_tt Bool.and_true
#align band_ff Bool.and_false
#align tt_band Bool.true_and
#align ff_band Bool.false_and
#align bor_self Bool.or_self
#align bor_tt Bool.or_true
#align bor_ff Bool.or_false
#align tt_bor Bool.true_or
#align ff_bor Bool.false_or
#align bnot_bnot Bool.not_not

namespace Bool

-- In Lean 3 we had `attribute [simp] cond or and not xor` in the corresponding
-- file, but in Lean 4 this makes the `simpNF` linter complain, so instead we
-- manually generate the corresponding equation lemmas and tag them with `@[simp]` instead.
-- `or`, `and`, and `not` are already done in core Lean 4; here is `cond`, and `xor` is done below.
@[simp] lemma cond_true {α : Type u} {a b : α} : cond true a b = a := rfl
#align bool.cond_tt Bool.cond_true

@[simp] lemma cond_false {α : Type u} {a b : α} : cond false a b = b := rfl
#align bool.cond_ff Bool.cond_false

@[simp]
theorem cond_self.{u} {α : Type u} (b : Bool) (a : α) : cond b a a = a := by cases b <;> rfl
#align cond_a_a Bool.cond_self

@[simp]
theorem xor_self (b : Bool) : xor b b = false := by cases b <;> simp
#align bxor_self Bool.xor_self

@[simp]
theorem xor_true (b : Bool) : xor b true = not b := by cases b <;> simp
#align bxor_tt Bool.xor_true

theorem xor_false (b : Bool) : xor b false = b := by cases b <;> simp
#align bxor_ff Bool.xor_false

@[simp]
theorem true_xor (b : Bool) : xor true b = not b := by cases b <;> simp
#align tt_bxor Bool.true_xor

theorem false_xor (b : Bool) : xor false b = b := by cases b <;> simp
#align ff_bxor Bool.false_xor

theorem true_eq_false_eq_False : ¬true = false := by decide
#align tt_eq_ff_eq_false Bool.true_eq_false_eq_False

theorem false_eq_true_eq_False : ¬false = true := by decide
#align ff_eq_tt_eq_false Bool.false_eq_true_eq_False

theorem eq_false_eq_not_eq_true (b : Bool) : (¬b = true) = (b = false) := by simp
#align eq_ff_eq_not_eq_tt Bool.eq_false_eq_not_eq_true

theorem eq_true_eq_not_eq_false (b : Bool) : (¬b = false) = (b = true) := by simp
#align eq_tt_eq_not_eq_ft Bool.eq_true_eq_not_eq_false

theorem eq_false_of_not_eq_true {b : Bool} : ¬b = true → b = false :=
  Eq.mp (eq_false_eq_not_eq_true b)
#align eq_ff_of_not_eq_tt Bool.eq_false_of_not_eq_true

theorem eq_true_of_not_eq_false {b : Bool} : ¬b = false → b = true :=
  Eq.mp (eq_true_eq_not_eq_false b)
#align eq_tt_of_not_eq_ff Bool.eq_true_of_not_eq_false

theorem and_eq_true_eq_eq_true_and_eq_true (a b : Bool) :
    ((a && b) = true) = (a = true ∧ b = true) := by simp
#align band_eq_true_eq_eq_tt_and_eq_tt Bool.and_eq_true_eq_eq_true_and_eq_true

theorem or_eq_true_eq_eq_true_or_eq_true (a b : Bool) :
    ((a || b) = true) = (a = true ∨ b = true) := by simp
#align bor_eq_true_eq_eq_tt_or_eq_tt Bool.or_eq_true_eq_eq_true_or_eq_true

theorem not_eq_true_eq_eq_false (a : Bool) : (not a = true) = (a = false) := by cases a <;> simp
#align bnot_eq_true_eq_eq_ff Bool.not_eq_true_eq_eq_false

@[simp]
theorem and_eq_false_eq_eq_false_or_eq_false (a b : Bool) :
    ((a && b) = false) = (a = false ∨ b = false) := by
  cases a <;> cases b <;> simp
#align band_eq_false_eq_eq_ff_or_eq_ff Bool.and_eq_false_eq_eq_false_or_eq_false

@[simp]
theorem or_eq_false_eq_eq_false_and_eq_false (a b : Bool) :
    ((a || b) = false) = (a = false ∧ b = false) := by
  cases a <;> cases b <;> simp
#align bor_eq_false_eq_eq_ff_and_eq_ff Bool.or_eq_false_eq_eq_false_and_eq_false

theorem not_eq_false_eq_eq_true (a : Bool) : (not a = false) = (a = true) := by cases a <;> simp
#align bnot_eq_ff_eq_eq_tt Bool.not_eq_false_eq_eq_true

theorem coe_false : ↑false = False := by simp
#align coe_ff Bool.coe_false

theorem coe_true : ↑true = True := by simp
#align coe_tt Bool.coe_true

theorem coe_sort_false : (↥false : Prop) = False := by simp
#align coe_sort_ff Bool.coe_sort_false

theorem coe_sort_true : (↥true : Prop) = True := by simp
#align coe_sort_tt Bool.coe_sort_true

theorem decide_iff (p : Prop) [d : Decidable p] : decide p = true ↔ p := by simp
#align to_bool_iff Bool.decide_iff

theorem decide_true {p : Prop} [Decidable p] : p → decide p :=
  (decide_iff p).2
#align to_bool_true Bool.decide_true
#align to_bool_tt Bool.decide_true

theorem of_decide_true {p : Prop} [Decidable p] : decide p → p :=
  (decide_iff p).1
#align of_to_bool_true Bool.of_decide_true

theorem bool_iff_false {b : Bool} : ¬b ↔ b = false := by cases b <;> exact by decide
#align bool_iff_false Bool.bool_iff_false

theorem bool_eq_false {b : Bool} : ¬b → b = false :=
  bool_iff_false.1
#align bool_eq_false Bool.bool_eq_false

theorem decide_false_iff (p : Prop) [Decidable p] : decide p = false ↔ ¬p :=
  bool_iff_false.symm.trans (not_congr (decide_iff _))
#align to_bool_ff_iff Bool.decide_false_iff

theorem decide_false {p : Prop} [Decidable p] : ¬p → decide p = false :=
  (decide_false_iff p).2
#align to_bool_ff Bool.decide_false

theorem of_decide_false {p : Prop} [Decidable p] : decide p = false → ¬p :=
  (decide_false_iff p).1
#align of_to_bool_ff Bool.of_decide_false

theorem decide_congr {p q : Prop} [Decidable p] [Decidable q] (h : p ↔ q) :
    decide p = decide q := by
  cases h' : decide q with
  | false => exact decide_false (mt h.1 <| of_decide_false h')
  | true => exact decide_true (h.2 <| of_decide_true h')
#align to_bool_congr Bool.decide_congr

theorem or_coe_iff (a b : Bool) : a || b ↔ a ∨ b := by simp
#align bor_coe_iff Bool.or_coe_iff

theorem and_coe_iff (a b : Bool) : a && b ↔ a ∧ b := by simp
#align band_coe_iff Bool.and_coe_iff

@[simp]
theorem xor_coe_iff (a b : Bool) : xor a b ↔ Xor' (a = true) (b = true) := by
  cases a <;> cases b <;> exact by decide
#align bxor_coe_iff Bool.xor_coe_iff

@[simp]
theorem ite_eq_true_distrib (c : Prop) [Decidable c] (a b : Bool) :
    ((if c then a else b) = true) = if c then a = true else b = true := by by_cases c <;> simp [*]
#align ite_eq_tt_distrib Bool.ite_eq_true_distrib

@[simp]
theorem ite_eq_false_distrib (c : Prop) [Decidable c] (a b : Bool) :
    ((if c then a else b) = false) = if c then a = false else b = false := by
  by_cases c <;> simp [*]
#align ite_eq_ff_distrib Bool.ite_eq_false_distrib

end Bool


import Mathlib
import SciLean.Mathlib.Algebra.Module.Basic

class Symbolic {Repr : Type} (R : Repr → Repr → Prop) where
  RedForm  : Repr → Prop
  NormForm : Repr → Prop
  norm_red : ∀ x, NormForm x → RedForm x
  R_norm  : ∀ x y, R x y → NormForm x → NormForm y → x = y

namespace Symbolic

  -- define Hom     -- preserves relation
  -- define RedHom  -- preserving RefForm
  -- define NormHom -- preserving RefForm
  -- define their Hom₂ variants
  section Hom
    variable {Repr Repr'}
      (R  : Repr  → Repr  → Prop) [Symbolic R]
      (R' : Repr' → Repr' → Prop) [Symbolic R']
      (f : Repr → Repr')

    structure Hom : Prop where
      is_hom : ∀ x y : Repr, R x y → R' (f x) (f y)

    structure RedHom : Prop where
      is_hom : ∀ x y : Repr, R x y → R' (f x) (f y)
      preserve_red  : ∀ x : Repr, RedForm R x → RedForm R' (f x)

    structure NormHom : Prop where
      is_hom : ∀ x y : Repr, R x y → R' (f x) (f y)
      preserve_red  : ∀ x : Repr, RedForm R x → RedForm R' (f x)
      preserve_norm : ∀ x : Repr, NormForm R x → NormForm R' (f x)

  end Hom

  structure SHom {Repr Repr'}
    (R  : Repr  → Repr  → Prop) [Symbolic R]
    (R' : Repr' → Repr' → Prop) [Symbolic R']
    (f : Repr → Repr') : Prop where
       is_hom : ∀ x y : Repr, R x y → R' (f x) (f y)
       preserve_red  : ∀ x : Repr, RedForm R x → RedForm R' (f x)
       preserve_norm : ∀ x : Repr, NormForm R x → NormForm R' (f x)

  structure SHom₂ {Repr Repr' Repr''}
    (R : Repr → Repr → Prop) [Symbolic R]
    (R' : Repr' → Repr' → Prop) [Symbolic R']
    (R'' : Repr'' → Repr'' → Prop) [Symbolic R'']
    (f : Repr → Repr' → Repr'') : Prop where
      is_hom₂ : ∀ (x y : Repr) (x' y' : Repr'), R x y → R' x' y' → R'' (f x x') (f y y')
      preserve_red  : ∀ x x', RedForm R x → RedForm R' x' → RedForm R'' (f x x')
      preserve_norm : ∀ x x', NormForm R x → NormForm R' x' → NormForm R'' (f x x')

  class SReduce {Repr} (R : Repr → Repr → Prop) [Symbolic R] where
    reduce : Repr → Repr
    is_reduce : ∀ x, RedForm R (reduce x)
    R_reduce : ∀ x, R x (reduce x)
    reduce_of_norm : ∀ x, NormForm R x → NormForm R (reduce x) -- does not destroy norm form

  -- symbolic reduction on quotient will be identity
  class Reduce (X : Type u) where
    reduce : X → X
    id_reduce : ∀ x : X, reduce x = x

  class SNormalize {Repr} (R : Repr → Repr → Prop) [Symbolic R] where
    normalize : Repr → Repr
    is_normalize : ∀ x, NormForm R (normalize x)
    R_normalize : ∀ x, R x (normalize x)

  -- symbolic normalization on quotient will be identity
  class Normalize (X : Type u) where
    normalize : X → X
    id_normalize : ∀ x : X, normalize x = x

  -- This just tags `Repr` in which form they are
  inductive SRepr {Repr : Type} (R : Repr → Repr → Prop) [Symbolic R] where
    | raw  (x : Repr) : SRepr R
    | red  (x : Repr) (h : RedForm R x)  : SRepr R
    | norm (x : Repr) (h : NormForm R x) : SRepr R

  namespace SRepr

    variable {Repr} {R : Repr → Repr → Prop} [Symbolic R]

    def repr (x : SRepr R) : Repr :=
      match x with
      | raw  x   => x
      | red  x _ => x
      | norm x _ => x

    -- instance : Coe (SRepr R) Repr := ⟨λ x => x.repr⟩

    @[simp]
    theorem raw_repr (x : Repr) : (raw x : SRepr R).repr = x := by simp[repr] done

    @[simp]
    theorem red_repr (x : Repr) (h : RedForm R x) : (red x h : SRepr R).repr = x := by simp[repr] done

    @[simp]
    theorem norm_repr (x : Repr) (h : NormForm R x) : (norm x h : SRepr R).repr = x := by simp[repr] done

    def isReduced (x : SRepr R) : Bool :=
      match x with
      | raw x => false
      | _ => true

    def isNormalized (x : SRepr R) : Bool :=
      match x with
      | norm x _ => true
      | _ => false

    variable {Repr' } {R'  : Repr'  → Repr'  → Prop} [Symbolic R']
    variable {Repr''} {R'' : Repr'' → Repr'' → Prop} [Symbolic R'']

    def lift (f : Repr → Repr') (x : SRepr R) : SRepr R' := raw (f x.repr)

    def lift₂ (f : Repr → Repr' → Repr'') (x : SRepr R) (x' : SRepr R') : SRepr R'' :=
      raw (f x.repr x'.repr)

    def liftHom (f : Repr → Repr') (h : SHom R R' f) (x : SRepr R) : SRepr R' :=
      match x with
      | raw x => raw (f x)
      | red  x h' => red  (f x) (h.preserve_red x h')
      | norm x h' => norm (f x) (h.preserve_norm x h')

    @[simp]
    theorem lift_hom_repr (f : Repr → Repr') (h : SHom R R' f) (x : SRepr R)
      : (liftHom f h x).repr = f x.repr
      :=
      by induction x
         repeat simp[liftHom]
         done

    def liftHom₂ (f : Repr → Repr' → Repr'') (h : SHom₂ R R' R'' f)
      (x : SRepr R) (y : SRepr R') : SRepr R'' :=
      match x, y with
      | red x hx,  red y hy  => red  (f x y) (h.preserve_red  x y hx hy)
      | norm x hx, norm y hy => norm (f x y) (h.preserve_norm x y hx hy)
      | x, y => raw (f x.repr y.repr)

    def reduce (x : SRepr R) [SReduce R] : SRepr R :=
      match x with
      | raw x => red (SReduce.reduce R x) (SReduce.is_reduce x)
      | x => x

    def normalize (x : SRepr R) [SNormalize R] : SRepr R :=
      match x with
      | raw x   => norm (SNormalize.normalize R x) (SNormalize.is_normalize x)
      | red x _ => norm (SNormalize.normalize R x) (SNormalize.is_normalize x)
      | x => x

  end SRepr

  def SQuot {Repr} (R : Repr → Repr → Prop) [Symbolic R]
    := Quot (λ x y : SRepr R => R x.repr y.repr)

  variable {Repr} {R : Repr → Repr → Prop} [Symbolic R]
  variable {Repr'} {R' : Repr' → Repr' → Prop} [Symbolic R']
  variable {Repr''} {R'' : Repr'' → Repr'' → Prop} [Symbolic R'']

  -- Not sure about these two with the coercion from SRepr to Repr
  def SQuot.mk  (x : SRepr R) : SQuot R := Quot.mk _ x
  def SQuot.rmk (x : Repr)    : SQuot R := Quot.mk _ (SRepr.raw x)

  def SQuot.mkRed  (x : Repr) (h : RedForm R x)  : SQuot R := Quot.mk _ (SRepr.red  x h)
  def SQuot.mkNorm (x : Repr) (h : NormForm R x) : SQuot R := Quot.mk _ (SRepr.norm x h)

  def SQuot.lift {α : Sort u} (f : Repr → α) (h : ∀ x x' : Repr, R x x' → f x = f x')
    : SQuot R → α
    := Quot.lift (λ x => f x.repr)
         (by intros a b
             induction a
             repeat(
               induction b
               repeat(
                 simp[SRepr.repr]
                 apply h)))

  def SQuot.slift {α : Sort u} (f : SRepr R → α) (h : ∀ x x' : SRepr R, R x.repr x'.repr → f x = f x')
    : SQuot R → α
    := Quot.lift (λ x => f x) h

  def SQuot.liftHom (f : Repr → Repr') (h : SHom R R' f)
    : SQuot R → SQuot R'
    := Quot.lift (λ x' => Quot.mk _ (SRepr.liftHom f h x'))
        (by intro a b req
            apply Quot.sound
            induction a
            repeat
              (induction b
               repeat
                 (simp at req
                  apply h.is_hom
                  assumption))
            done)

  def SQuot.lift₂ (f : Repr → Repr' → Repr'')
      (h : ∀ (x y : Repr) (x' y' : Repr'), R x y → R' x' y' → R'' (f x x') (f y y'))
      : SQuot R → SQuot R' → SQuot R''
      := Quot.lift (λ x' => Quot.lift (λ y' => Quot.mk _ (SRepr.lift₂ f x' y')) sorry) sorry

  def SQuot.slift₂ (f : SRepr R → SRepr R' → SRepr R'')
      (h : ∀ (x y : SRepr R) (x' y' : SRepr R'), R x.repr y.repr → R' x'.repr y'.repr → R'' (f x x').repr (f y y').repr)
      : SQuot R → SQuot R' → SQuot R''
      := Quot.lift (λ x' => Quot.lift (λ y' => Quot.mk _ (f x' y')) sorry) sorry

  def SQuot.liftHom₂ (f : Repr → Repr' → Repr'') (h : SHom₂ R R' R'' f)
    : SQuot R → SQuot R' → SQuot R''
    := Quot.lift (λ x' => Quot.lift (λ y' => Quot.mk _ (SRepr.liftHom₂ f h x' y')) sorry) sorry

  instance [SReduce R] : Reduce (SQuot R) :=
  {
    reduce := SQuot.slift (λ x => Quot.mk _ x.reduce) sorry
    id_reduce := sorry
  }

  instance [SNormalize R] : Normalize (SQuot R) :=
  {
    normalize := SQuot.slift (λ x => Quot.mk _ x.normalize) sorry
    id_normalize := sorry
  }

  -- variable {Repr : Type} {RedForm : Repr → Prop} {NormForm : Repr → Prop}

  -- instance : Coe (Symbolic Repr RedForm NormForm) Repr := ⟨repr⟩

  -- def isReduced (x : Symbolic Repr RedForm NormForm) : Bool :=
  --   match x with
  --   | raw _ => false
  --   | _ => true

  -- def isNormalized (x : Symbolic Repr RedForm NormForm) : Bool :=
  --   match x with
  --   | norm _ _ => true
  --   | _ => false

  -- -- Lift reduction preserving function `Repr → Repr'` to Symbolic
  -- def liftHom {Repr' : Type} {RedForm' NormForm' : Repr' → Prop}
  --   (f : Repr → Repr')
  --   (h  : ∀ x : Repr, RedForm x → RedForm' (f x))
  --   (h' : ∀ x : Repr, NormForm x → NormForm' (f x))
  --   (x : Symbolic Repr RedForm NormForm)
  --   : Symbolic Repr' RedForm' NormForm'
  --   :=
  --   match x with
  --   | raw  x => raw (f x)
  --   | red  x g => red  (f x) (h  x g)
  --   | norm x g => norm (f x) (h' x g)

  -- def Symb {Repr} (R : Repr → Repr → Prop) (RedForm NormForm : Repr → Prop)
  --   (h : ∀ x y : Repr, R x y → NormForm x → NormForm y → x = y)
  --   := Quot (λ x y : Symbolic Repr RedForm NormForm => R x y)

  -- variable {R : outParam $ Repr → Repr → Prop}
  --   {RedForm NormForm : outParam $ Repr → Prop}
  --   {H : outParam $ ∀ x y : Repr, R x y → NormForm x → NormForm y → x = y}

  -- def Symb.lift {α : Sort u} (f : Repr → α) (h : ∀ x y : Repr, R x y → f x = f y)
  --   (x : Symb R RedForm NormForm H) : α
  --   := Quot.lift (λ x => f x) (by intro a b; induction a; induction b;
  --                                 repeat (simp; apply h)
  --                                 done) x

  -- def Symb.liftSnd
  --   {α : Sort u} {β : Sort v} (f : β → Repr → α) (h : ∀ b (x y : Repr), R x y → f b x = f b y) (b : β)
  --   : Symb R RedForm NormForm H → α
  --   := Quot.lift (λ x => f b x) (by intro x y; induction x; induction y;
  --                                   repeat (simp; apply (h b))
  --                                   done)

  -- def Symb.lift₂ {α : Sort u} (f : Repr → Repr → α)
  --     (h  : ∀ x y y' : Repr, R y y' → f x y = f x y')
  --     (h' : ∀ (x x' : Repr), R x x' → liftSnd (RedForm := RedForm) (NormForm := NormForm) (H := H) f h x = liftSnd f h x')
  --     (x y : Symb R RedForm NormForm H) : α
  --     := lift (liftSnd f h) h' x y

  -- constant toString [ToString Repr] (x : Symb R RedForm NormForm H) : String
  --     := Symb.lift (λ r => toString r) sorry (x)

  -- -- `reduce` function should send representative to its reduced form
  -- class Reduce (X : Type) where
  --   reduce : X → X
  --   reduce_id : ∀ x, reduce x = x

  -- def lift_reduce (reduce : Repr → Repr)
  --   (h  : ∀ x, RedForm (reduce x)) (h' : ∀ x, NormForm x → RedForm x)
  --   (x : Symbolic Repr RedForm NormForm) : (Symbolic Repr RedForm NormForm)
  --   :=
  --   match x with
  --   | raw x => red (reduce x) (h x)
  --   | x => x

  -- -- `normalize` function should send representative to its normal form
  -- class Normalize (X : Type) where
  --   normalize : X → X
  --   normalize_id : ∀ x, normalize x = x

  -- def lift_normalize (normalize : Repr → Repr)
  --   (h  : ∀ x, NormForm (normalize x))
  --   (x : Symbolic Repr RedForm NormForm) : (Symbolic Repr RedForm NormForm)
  --   :=
  --   match x with
  --   | raw x   => norm (normalize x) (h x)
  --   | red x _ => norm (normalize x) (h x)
  --   | x => x

end Symbolic

inductive List.Sorted {X : Type u} [LE X] : List X → Prop where
| empty : Sorted []
| singl (x : X) : Sorted [x]
| head  (x y : X) (ys : List X) (h : x ≤ y) (h' : Sorted (y :: ys))
        : Sorted (x :: y :: ys)

inductive List.StrictlySorted {X : Type u} [LT X] : List X → Prop where
| empty : StrictlySorted []
| singl (x : X) : StrictlySorted [x]
| head  (x y : X) (ys : List X) (h : x < y)
        (h' : StrictlySorted (y :: ys))
        : StrictlySorted (x :: y :: ys)

structure FreeMonoid (X : Type u) where
  vars : List X

namespace FreeMonoid

  instance {X} : Mul (FreeMonoid X) := ⟨λ x y => ⟨x.1.append y.1⟩⟩
  instance {X} : One (FreeMonoid X) := ⟨⟨[]⟩⟩

  def rank {X} (x : FreeMonoid X) : Nat := x.1.length

  inductive SymmMonoidEq {X} : FreeMonoid X → FreeMonoid X → Prop where
    | mul_comm (x y : FreeMonoid X) : SymmMonoidEq (x*y) (y*x)

end FreeMonoid

namespace Monomial

  structure Repr (X : Type u) (K : Type v) where
    coef : K
    base : FreeMonoid X

  instance {X K} [Mul K] : Mul (Repr X K) :=
    ⟨λ x y => ⟨x.coef * y.coef, x.base * y.base⟩⟩
  instance {X K} [Mul K] : HMul K (Repr X K) (Repr X K) :=
    ⟨λ a x => ⟨a * x.coef, x.base⟩⟩

  def Repr.rank {X K} (x : Repr X K) : Nat := x.base.rank

  inductive SymMonomialEq {X K : Type} [One K] [Neg K] [Mul K] [HPow K Nat K] : Repr X K → Repr X K → Prop where
    | refl (x : Repr X K) : SymMonomialEq x x
    | mul_comm (x y : Repr X K) : SymMonomialEq (x * y) (y * x)

  inductive AltMonomialEq {X K : Type} [One K] [Neg K] [Mul K] [HPow K Nat K] : Repr X K → Repr X K → Prop where
    | refl (x : Repr X K) : AltMonomialEq x x
    | mul_alt (x y : Repr X K) : AltMonomialEq (x * y) ((-1 : K)^(x.rank + y.rank) * y * x)

  instance {X K} [LT X] [CommRing K] : Symbolic (SymMonomialEq (X := X) (K := K)) :=
  {
    RedForm  := λ x => x.base.1.StrictlySorted
    NormForm := λ x => (x.base.1.StrictlySorted) ∧ (x.coef = 0 → x.base.1 = [])
    norm_red := λ x h => h.left
    R_norm   := sorry -- this is probably hard as I need CommRing for it
  }

  instance {X K} [LT X] [CommRing K] : Symbolic (AltMonomialEq (X := X) (K := K)) :=
  {
    RedForm  := λ x => x.base.1.StrictlySorted
    NormForm := λ x => (x.base.1.StrictlySorted) ∧ (x.coef = 0 → x.base.1 = [])
    norm_red := λ x h => h.left
    R_norm   := sorry -- this is probably hard as I need CommRing for it
  }

end Monomial

open Symbolic Monomial in
def SymMonomial (X K) [LT X] [CommRing K] := SQuot (SymMonomialEq (X := X) (K := K))

open Symbolic Monomial in
def AltMonomial (X K) [LT X] [CommRing K] := SQuot (AltMonomialEq (X := X) (K := K))

inductive DecComparison {X : Type u} [LT X] (x y : X) where
  | cpEq (h : x = y) : DecComparison x y
  | cpLt (h : x < y) : DecComparison x y
  | cpGt (h : x > y) : DecComparison x y

export DecComparison (cpEq cpLt cpGt)

class DecCompar (X : Type u) [LT X] where
  compare (x y : X) : DecComparison x y

abbrev compare {X} [LT X] [DecCompar X] (x y : X) : DecComparison x y := DecCompar.compare x y

namespace AltMonomial
  open Symbolic

  variable {X K} [LT X] [DecCompar X] [CommRing K]

  instance [DecCompar X] : Reduce (AltMonomial X K) :=
  {
    reduce := sorry
    id_reduce := sorry
  }

  instance [DecCompar X] [DecidableEq K] : Normalize (AltMonomial X K) :=
  {
    normalize := sorry
    id_normalize := sorry
  }

  -- TODO: change these definitions
  --       add reduction
  instance : Mul  (AltMonomial X K) := ⟨λ x' y' => (SQuot.lift₂ (λ x y => (x * y)) sorry) x' y' |> Reduce.reduce⟩
  instance [Mul K] : HMul K (AltMonomial X K) (AltMonomial X K) := ⟨λ c => SQuot.lift (λ x => SQuot.rmk (c * x)) sorry⟩
  instance : One  (AltMonomial X K) := ⟨SQuot.mkNorm ⟨1,1⟩ sorry⟩
  instance : Zero (AltMonomial X K) := ⟨SQuot.mkNorm ⟨0,1⟩ sorry⟩

  instance : Monoid (AltMonomial X K) :=
  {
    mul_assoc := sorry
    mul_one := sorry
    one_mul := sorry
    npow_zero' := sorry
    npow_succ' := sorry
  }

  instance : MulAction K (AltMonomial X K) :=
  {
    one_smul := sorry
    mul_smul := sorry
  }

end AltMonomial


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

More partial recursive functions using a universal program;
Rice's theorem and the halting problem.
-/
import computability.partrec_code

open encodable denumerable

namespace nat.partrec
open computable roption

theorem merge' {f g}
  (hf : nat.partrec f) (hg : nat.partrec g) :
  ∃ h, nat.partrec h ∧ ∀ a,
    (∀ x ∈ h a, x ∈ f a ∨ x ∈ g a) ∧
    ((h a).dom ↔ (f a).dom ∨ (g a).dom) :=
begin
  rcases code.exists_code.1 hf with ⟨cf, rfl⟩,
  rcases code.exists_code.1 hg with ⟨cg, rfl⟩,
  have : nat.partrec (λ n,
    (nat.rfind_opt (λ k, cf.evaln k n <|> cg.evaln k n))) :=
  partrec.nat_iff.1 (partrec.rfind_opt $
    primrec.option_orelse.to_comp.comp
      (code.evaln_prim.to_comp.comp $ (snd.pair (const cf)).pair fst)
      (code.evaln_prim.to_comp.comp $ (snd.pair (const cg)).pair fst)),
  refine ⟨_, this, λ n, _⟩,
  suffices, refine ⟨this,
    ⟨λ h, (this _ ⟨h, rfl⟩).imp Exists.fst Exists.fst, _⟩⟩,
  { intro h, rw nat.rfind_opt_dom,
    simp [dom_iff_mem, code.evaln_complete] at h,
    rcases h with ⟨x, k, e⟩ | ⟨x, k, e⟩,
    { refine ⟨k, x, _⟩, simp [e] },
    { refine ⟨k, _⟩,
      cases cf.evaln k n with y,
      { exact ⟨x, by simp [e]⟩ },
      { exact ⟨y, by simp⟩ } } },
  { intros x h,
    rcases nat.rfind_opt_spec h with ⟨k, e⟩,
    revert e,
    simp; cases e' : cf.evaln k n with y; simp; intro,
    { exact or.inr (code.evaln_sound e) },
    { subst y,
        exact or.inl (code.evaln_sound e') } }
end

end nat.partrec

namespace partrec
variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*}
variables [primcodable α] [primcodable β] [primcodable γ] [primcodable σ]

open computable roption nat.partrec (code) nat.partrec.code

theorem merge' {f g : α →. σ}
  (hf : partrec f) (hg : partrec g) :
  ∃ k : α →. σ, partrec k ∧ ∀ a,
    (∀ x ∈ k a, x ∈ f a ∨ x ∈ g a) ∧
    ((k a).dom ↔ (f a).dom ∨ (g a).dom) :=
let ⟨k, hk, H⟩ :=
  nat.partrec.merge' (bind_decode2_iff.1 hf) (bind_decode2_iff.1 hg) in
begin
  let k' := λ a, (k (encode a)).bind (λ n, decode σ n),
  refine ⟨k', ((nat_iff.2 hk).comp computable.encode).bind
    (computable.decode.of_option.comp snd).to₂, λ a, _⟩,
  suffices, refine ⟨this,
    ⟨λ h, (this _ ⟨h, rfl⟩).imp Exists.fst Exists.fst, _⟩⟩,
  { intro h, simp [k'],
    have hk : (k (encode a)).dom :=
      (H _).2.2 (by simpa [encodek2] using h),
    existsi hk,
    cases (H _).1 _ ⟨hk, rfl⟩ with h h;
    { simp at h,
      rcases h with ⟨a', ha', y, hy, e⟩,
      simp [e.symm, encodek] } },
  { intros x h', simp [k'] at h',
    rcases h' with ⟨n, hn, hx⟩,
    have := (H _).1 _ hn,
    simp [mem_decode2, encode_injective.eq_iff] at this,
    cases this with h h;
    { rcases h with ⟨a', ha, rfl⟩,
      simp [encodek] at hx, subst a',
      simp [ha] } },
end

theorem merge {f g : α →. σ}
  (hf : partrec f) (hg : partrec g)
  (H : ∀ a (x ∈ f a) (y ∈ g a), x = y) :
  ∃ k : α →. σ, partrec k ∧ ∀ a x, x ∈ k a ↔ x ∈ f a ∨ x ∈ g a :=
let ⟨k, hk, K⟩ := merge' hf hg in
⟨k, hk, λ a x, ⟨(K _).1 _, λ h, begin
  have : (k a).dom := (K _).2.2 (h.imp Exists.fst Exists.fst),
  refine ⟨this, _⟩,
  cases h with h h; cases (K _).1 _ ⟨this, rfl⟩ with h' h',
  { exact mem_unique h' h },
  { exact (H _ _ h _ h').symm },
  { exact H _ _ h' _ h },
  { exact mem_unique h' h }
end⟩⟩

theorem cond {c : α → bool} {f : α →. σ} {g : α →. σ}
  (hc : computable c) (hf : partrec f) (hg : partrec g) :
  partrec (λ a, cond (c a) (f a) (g a)) :=
let ⟨cf, ef⟩ := exists_code.1 hf,
    ⟨cg, eg⟩ := exists_code.1 hg in
((eval_part.comp
    (computable.cond hc (const cf) (const cg)) computable.id).bind
  ((@computable.decode σ _).comp snd).of_option.to₂).of_eq $
λ a, by cases c a; simp [ef, eg, encodek]

theorem sum_cases
  {f : α → β ⊕ γ} {g : α → β →. σ} {h : α → γ →. σ}
  (hf : computable f) (hg : partrec₂ g) (hh : partrec₂ h) :
  @partrec _ σ _ _ (λ a, sum.cases_on (f a) (g a) (h a)) :=
option_some_iff.1 $ (cond
  (sum_cases hf (const tt).to₂ (const ff).to₂)
  (sum_cases_left hf (option_some_iff.2 hg).to₂ (const option.none).to₂)
  (sum_cases_right hf (const option.none).to₂ (option_some_iff.2 hh).to₂))
.of_eq $ λ a, by cases f a; simp

end partrec

def computable_pred {α} [primcodable α] (p : α → Prop) :=
∃ [D : decidable_pred p],
by exactI computable (λ a, to_bool (p a))

/- recursively enumerable predicate -/
def re_pred {α} [primcodable α] (p : α → Prop) :=
partrec (λ a, roption.assert (p a) (λ _, roption.some ()))

theorem computable_pred.of_eq {α} [primcodable α]
  {p q : α → Prop}
  (hp : computable_pred p) (H : ∀ a, p a ↔ q a) : computable_pred q :=
(funext (λ a, propext (H a)) : p = q) ▸ hp

namespace computable_pred
variables {α : Type*} {σ : Type*}
variables [primcodable α] [primcodable σ]
open nat.partrec (code) nat.partrec.code computable

theorem rice (C : set (ℕ →. ℕ))
  (h : computable_pred (λ c, eval c ∈ C))
  {f g} (hf : nat.partrec f) (hg : nat.partrec g)
  (fC : f ∈ C) : g ∈ C :=
begin
  cases h with _ h, resetI,
  rcases fixed_point₂ (partrec.cond (h.comp fst)
    ((partrec.nat_iff.2 hg).comp snd).to₂
    ((partrec.nat_iff.2 hf).comp snd).to₂).to₂ with ⟨c, e⟩,
  simp at e,
  by_cases eval c ∈ C,
  { simp [h] at e, rwa ← e },
  { simp at h, simp [h] at e,
    rw e at h, contradiction }
end

theorem rice₂ (C : set code)
  (H : ∀ cf cg, eval cf = eval cg → (cf ∈ C ↔ cg ∈ C)) :
  computable_pred (λ c, c ∈ C) ↔ C = ∅ ∨ C = set.univ :=
by haveI := classical.dec; exact
have hC : ∀ f, f ∈ C ↔ eval f ∈ eval '' C,
from λ f, ⟨set.mem_image_of_mem _, λ ⟨g, hg, e⟩, (H _ _ e).1 hg⟩,
⟨λ h, or_iff_not_imp_left.2 $ λ C0,
  set.eq_univ_of_forall $ λ cg,
  let ⟨cf, fC⟩ := set.ne_empty_iff_exists_mem.1 C0 in
  (hC _).2 $ rice (eval '' C) (h.of_eq hC)
    (partrec.nat_iff.1 $ eval_part.comp (const cf) computable.id)
    (partrec.nat_iff.1 $ eval_part.comp (const cg) computable.id)
    ((hC _).1 fC),
λ h, by rcases h with rfl | rfl; simp [computable_pred];
  exact ⟨by apply_instance, computable.const _⟩⟩

theorem halting_problem (n) : ¬ computable_pred (λ c, (eval c n).dom)
| h := rice {f | (f n).dom} h nat.partrec.zero nat.partrec.none trivial

end computable_pred

namespace nat
open vector roption

/-- A simplified basis for `partrec`. -/
inductive partrec' : ∀ {n}, (vector ℕ n →. ℕ) → Prop
| prim {n f} : @primrec' n f → @partrec' n f
| comp {m n f} (g : fin n → vector ℕ m →. ℕ) :
  partrec' f → (∀ i, partrec' (g i)) →
  partrec' (λ v, m_of_fn (λ i, g i v) >>= f)
| rfind {n} {f : vector ℕ (n+1) → ℕ} : @partrec' (n+1) f →
  partrec' (λ v, rfind (λ n, some (f (n :: v) = 0)))

end nat

namespace nat.partrec'
open vector partrec computable nat (partrec') nat.partrec'

theorem to_part {n f} (pf : @partrec' n f) : partrec f :=
begin
  induction pf,
  case nat.partrec'.prim : n f hf { exact hf.to_prim.to_comp },
  case nat.partrec'.comp : m n f g _ _ hf hg {
    exact (vector_m_of_fn (λ i, hg i)).bind (hf.comp snd) },
  case nat.partrec'.rfind : n f _ hf {
    have := ((primrec.eq.comp primrec.id (primrec.const 0)).to_comp.comp
      (hf.comp (vector_cons.comp snd fst))).to₂.part,
    exact this.rfind },
end

theorem of_eq {n} {f g : vector ℕ n →. ℕ}
  (hf : partrec' f) (H : ∀ i, f i = g i) : partrec' g :=
(funext H : f = g) ▸ hf

theorem of_prim {n} {f : vector ℕ n → ℕ} (hf : primrec f) : @partrec' n f :=
prim (nat.primrec'.of_prim hf)

theorem head {n : ℕ} : @partrec' n.succ (@head ℕ n) :=
prim nat.primrec'.head

theorem tail {n f} (hf : @partrec' n f) : @partrec' n.succ (λ v, f v.tail) :=
(hf.comp _ (λ i, @prim _ _ $ nat.primrec'.nth i.succ)).of_eq $
λ v, by simp; rw [← of_fn_nth v.tail]; congr; funext i; simp

protected theorem bind {n f g}
  (hf : @partrec' n f) (hg : @partrec' (n+1) g) :
  @partrec' n (λ v, (f v).bind (λ a, g (a :: v))) :=
(@comp n (n+1) g
  (λ i, fin.cases f (λ i v, some (v.nth i)) i) hg
  (λ i, begin
    refine fin.cases _ (λ i, _) i; simp *,
    exact prim (nat.primrec'.nth _)
  end)).of_eq $
λ v, by simp [m_of_fn, roption.bind_assoc, pure]

protected theorem map {n f} {g : vector ℕ (n+1) → ℕ}
  (hf : @partrec' n f) (hg : @partrec' (n+1) g) :
  @partrec' n (λ v, (f v).map (λ a, g (a :: v))) :=
by simp [(roption.bind_some_eq_map _ _).symm];
   exact hf.bind hg

def vec {n m} (f : vector ℕ n → vector ℕ m) :=
∀ i, partrec' (λ v, (f v).nth i)

theorem vec.prim {n m f} (hf : @nat.primrec'.vec n m f) : vec f :=
λ i, prim $ hf i

protected theorem nil {n} : @vec n 0 (λ _, nil) := λ i, i.elim0

protected theorem cons {n m} {f : vector ℕ n → ℕ} {g}
  (hf : @partrec' n f) (hg : @vec n m g) :
  vec (λ v, f v :: g v) :=
λ i, fin.cases (by simp *) (λ i, by simp [hg i]) i

theorem idv {n} : @vec n n id := vec.prim nat.primrec'.idv

theorem comp' {n m f g} (hf : @partrec' m f) (hg : @vec n m g) :
  partrec' (λ v, f (g v)) :=
(hf.comp _ hg).of_eq $ λ v, by simp

theorem comp₁ {n} (f : ℕ →. ℕ) {g : vector ℕ n → ℕ}
  (hf : @partrec' 1 (λ v, f v.head)) (hg : @partrec' n g) :
  @partrec' n (λ v, f (g v)) :=
by simpa using hf.comp' (partrec'.cons hg partrec'.nil)

theorem rfind_opt {n} {f : vector ℕ (n+1) → ℕ}
  (hf : @partrec' (n+1) f) :
  @partrec' n (λ v, nat.rfind_opt (λ a, of_nat (option ℕ) (f (a :: v)))) :=
((rfind $ (of_prim (primrec.nat_sub.comp (primrec.const 1) primrec.vector_head))
   .comp₁ (λ n, roption.some (1 - n)) hf)
   .bind ((prim nat.primrec'.pred).comp₁ nat.pred hf)).of_eq $
λ v, roption.ext $ λ b, begin
  simp [nat.rfind_opt, -nat.mem_rfind],
  refine exists_congr (λ a,
    (and_congr (iff_of_eq _) iff.rfl).trans (and_congr_right (λ h, _))),
  { congr; funext n,
    simp, cases f (n :: v); simp [nat.succ_ne_zero]; refl },
  { have := nat.rfind_spec h,
    simp at this,
    cases f (a :: v) with c, {cases this},
    rw [← option.some_inj, eq_comm], refl }
end

open nat.partrec.code
theorem of_part : ∀ {n f}, partrec f → @partrec' n f :=
suffices ∀ f, nat.partrec f → @partrec' 1 (λ v, f v.head), from
λ n f hf, begin
  let g, swap,
  exact (comp₁ g (this g hf) (prim nat.primrec'.encode)).of_eq
    (λ i, by dsimp [g]; simp [encodek, roption.map_id']),
end,
λ f hf, begin
  rcases exists_code.1 hf with ⟨c, rfl⟩,
  simpa [eval_eq_rfind_opt] using
    (rfind_opt $ of_prim $ primrec.encode_iff.2 $ evaln_prim.comp $
      (primrec.vector_head.pair (primrec.const c)).pair $
      primrec.vector_head.comp primrec.vector_tail)
end

theorem part_iff {n f} : @partrec' n f ↔ partrec f := ⟨to_part, of_part⟩

theorem part_iff₁ {f : ℕ →. ℕ} :
  @partrec' 1 (λ v, f v.head) ↔ partrec f :=
part_iff.trans ⟨
  λ h, (h.comp $ (primrec.vector_of_fn $
    λ i, primrec.id).to_comp).of_eq (λ v, by simp),
  λ h, h.comp vector_head⟩

theorem part_iff₂ {f : ℕ → ℕ →. ℕ} :
  @partrec' 2 (λ v, f v.head v.tail.head) ↔ partrec₂ f :=
part_iff.trans ⟨
  λ h, (h.comp $ vector_cons.comp fst $
    vector_cons.comp snd (const nil)).of_eq (λ v, by simp),
  λ h, h.comp vector_head (vector_head.comp vector_tail)⟩

theorem vec_iff {m n f} : @vec m n f ↔ computable f :=
⟨λ h, by simpa using vector_of_fn (λ i, to_part (h i)),
 λ h i, of_part $ vector_nth.comp h (const i)⟩

end nat.partrec'


lemma mul_left_comm (a b c : mynat) : a * (b * c) = b * (a * c) :=
begin
rwa [mul_comm a, mul_comm a, mul_assoc],
end