import ring_theory.ideals

namespace ideal
variables {α : Type*} [comm_ring α]

lemma ne_of_not_mem_mem {i₁ i₂ : ideal α} (a : α) : a ∉ i₁ → a ∈ i₂ → i₁ ≠ i₂ :=
λ ha₁ ha₂ h, ha₁ (by rwa h)

end ideal


import .expr_base
import ...phys.time.time
import data.real.basic

namespace lang.time

universes u
--variables
--  (K : Type u) [field K] [inhabited K]

abbreviation K := ℚ

variables  {f : fm K TIME} {sp : spc K f}

/-
Concern? This space parameter still needs to be here for now. Any environment function needs to know.
Response: It's ok. Consistent with the system design and operation.
-/
structure duration_var {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) extends var

/-
Time
-/
structure time_var {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f) extends var

/-
Begin: Earlier attempts at induction and time expressions, revealing some interesting situations.
-/

/-
mutual inductive duration_expr, time_expr {K : Type u} [field K] [inhabited K] {f : fm K TIME} (sp : spc K f)
with duration_expr : Type u
| lit (v : duration sp) : duration_expr
| var (v : duration_var sp) : duration_expr
| add_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| neg_dur (d : duration_expr) : duration_expr
| sub_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| sub_time_time (t1 : time_expr) (t2 : time_expr) : duration_expr
| smul_dur (k : K) (d : duration_expr) : duration_expr
with time_expr : Type u
| lit (p : time sp) : time_expr
| var (v : time_var sp) : time_expr
| add_dur_time (d : duration_expr) (t : time_expr) : time_expr
-/

/-
mutual inductive duration_expr, time_expr
with duration_expr : Π(K : Type u) [field K] [inhabited K], Type (u+1)
| zero : duration_expr
| one : duration_expr
| lit {f : fm K TIME} {sp : spc K f} (v : duration sp) : duration_expr
| var {f : fm K TIME} {sp : spc K f} (v : duration_var sp) : duration_expr
| add_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| neg_dur (d : duration_expr) : duration_expr
| sub_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| sub_time_time (t1 : time_expr K) (t2 : time_expr K) : duration_expr
| smul_dur (k : K) (d : duration_expr) : duration_expr
with time_expr : Π(K : Type u) [field K] [inhabited K], Type (u+1)
| lit {f : fm K TIME} {sp : spc K f} (p : time sp) : time_expr K
| var {f : fm K TIME} {sp : spc K f} (v : time_var sp) : time_expr K
| add_dur_time (d : duration_expr) (t : time_expr K) : time_expr K
-/

set_option trace.app_builder true
--set_option pp.raw true
--set_option pp.raw.maxDepth 10
--set_option pp.universes true
--set_option pp.all true
--#help options
--set_option trace.inductive_compiler.mutual.sizeof true
--set_option trace.type_context.unification_hint true
--set_option trace.inductive.unify true
--help options

/-
[app_builder] failed to create an 'sizeof'-application,
failed to solve unification constraint for #1 argument (?x_0 =?= fm K TIME)
-/
/-
mutual inductive duration_expr, time_expr --(K : Type u) [field K] [inhabited K]
with duration_expr : Type (u+1)
| zero : duration_expr
| one : duration_expr
| lit {K : Type u} [field K] [inhabited K] {f1 : fm K TIME} {sp : spc K f1} (v : duration sp) : duration_expr
with time_expr  : Type (u+1)
| lit {K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} (p : time sp) : time_expr
-/

/-
[app_builder] failed to create an 'sizeof'-application,
failed to solve unification constraint for #1 argument (?x_0 =?= fm K TIME)
-/
/-
mutual inductive duration_expr, time_expr --(K : Type u) [field K] [inhabited K]
with duration_expr : Type (u+1)
| zero : /-Π (K : Type u) [field K] [inhabited K],-/ duration_expr
| one : /-Π (K : Type u) [field K] [inhabited K],-/ duration_expr
| lit : Π /-{K : Type u} [field K] [inhabited K]-/ {f : fm K TIME} {sp : spc K f} (d : duration sp), duration_expr
| var : Π /-{K : Type u} [field K] [inhabited K]-/ {f : fm K TIME} {sp : spc K f}, Π (v : duration_var sp), duration_expr
| add_dur_dur : Π (d1 d2 : duration_expr), duration_expr
| neg_dur : Π (d : duration_expr), duration_expr
| sub_dur_dur : Π (d1 d2 : duration_expr), duration_expr
| sub_time_time : Π (t1 t2 : time_expr), duration_expr
| smul_dur : /-Π {K : Type u} [field K] [inhabited K],-/ Π (k : K), Π (d : duration_expr), duration_expr
with time_expr  : Type (u+1)
| lit : Π/-{K : Type u} [field K] [inhabited K]-/ {f : fm K TIME} {sp : spc K f} (t : time sp), time_expr
| var : Π/-{K : Type u} [field K] [inhabited K]-/ {f : fm K TIME} {sp : spc K f} (v : time_var sp),  time_expr
| add_dur_time : Π (d : duration_expr) (t : time_expr), time_expr
-/
set_option trace.app_builder true

set_option pp.universes true
set_option pp.implicit true
/-
#check ℝ

mutual inductive dexpr, texpr --(ℝ : Type 1) [field ℝ] [inhabited ℝ] -- {f : fm ℝ TIME} {sp : spc ℝ f}
with dexpr : Type (1+1)
| zero : /-Π (ℝ : Type u) [field ℝ] [inhabited ℝ],-/ dexpr
| one : /-Π (ℝ : Type u) [field ℝ] [inhabited ℝ],-/ dexpr
| lit : Π /-{ℝ : Type u} [field ℝ] [inhabited ℝ]-/ {f : fm ℝ TIME} {sp : spc ℝ f} (d : duration sp), dexpr
| var : Π /-{ℝ : Type u} [field ℝ] [inhabited ℝ]-/ {f : fm ℝ TIME} {sp : spc ℝ f}, Π (v : duration_var sp), dexpr
| add_dur_dur : Π (d1 d2 : dexpr), dexpr
| neg_dur : Π (d : dexpr), dexpr
| sub_dur_dur : Π (d1 d2 : dexpr), dexpr
| sub_time_time : Π (t1 t2 : texpr), dexpr
| smul_dur : /-Π {ℝ : Type u} [field ℝ] [inhabited ℝ],-/ Π (ℝ : ℝ), Π (d : dexpr), dexpr
with texpr  : Type (1+1)
| lit : Π/-{ℝ : Type u} [field ℝ] [inhabited ℝ]-/ {f : fm ℝ TIME} {sp : spc ℝ f} (t : time sp), texpr
| var : Π/-{ℝ : Type u} [field ℝ] [inhabited ℝ]-/ {f : fm ℝ TIME} {sp : spc ℝ f} (v : time_var sp),  texpr
| add_dur_time : Π (d : dexpr) (t : texpr), texpr
-/
/-
Current attempt. Still with some blockers below.
mutual inductive duration_expr, time_expr --(K : Type u) [field K] [inhabited K]
with duration_expr : Type (u+1)
| zero : Π (K : Type u) [field K] [inhabited K], duration_expr
| one : Π (K : Type u) [field K] [inhabited K], duration_expr
| lit : Π {K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} (d : duration sp), duration_expr
| var : Π {K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f}, Π (v : duration_var sp), duration_expr
| add_dur_dur : Π (d1 d2 : duration_expr), duration_expr
| neg_dur : Π (d : duration_expr), duration_expr
| sub_dur_dur : Π (d1 d2 : duration_expr), duration_expr
| sub_time_time : Π (t1 t2 : time_expr), duration_expr
| smul_dur : Π {K : Type u} [field K] [inhabited K], Π (k : K), Π (d : duration_expr), duration_expr
with time_expr  : Type (u+1)
| lit : Π{K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} (t : time sp), time_expr
| var : Π{K : Type u} [field K] [inhabited K] {f : fm K TIME} {sp : spc K f} (v : time_var sp),  time_expr
| add_dur_time : Π (d : duration_expr) (t : time_expr), time_expr
-/
mutual inductive duration_expr, time_expr --(K : Type u) [field K] [inhabited K]
with duration_expr : Type
| zero :  duration_expr
| one :  duration_expr
| lit : Π {f : fm K TIME} {sp : spc K f} (d : duration sp), duration_expr
| var : Π {f : fm K TIME} {sp : spc K f}, Π (v : duration_var sp), duration_expr
| add_dur_dur : Π (d1 d2 : duration_expr), duration_expr
| neg_dur : Π (d : duration_expr), duration_expr
| sub_dur_dur : Π (d1 d2 : duration_expr), duration_expr
| sub_time_time : Π (t1 t2 : time_expr), duration_expr
| smul_dur : Π (k : K), Π (d : duration_expr), duration_expr
with time_expr  : Type
| lit : Π {f : fm K TIME} {sp : spc K f} (t : time sp), time_expr
| var : Π {f : fm K TIME} {sp : spc K f} (v : time_var sp),  time_expr
| add_dur_time : Π (d : duration_expr) (t : time_expr), time_expr

notation `[`dlit`]` := duration_expr.lit dlit
notation `[`tlit`]` := time_expr.lit tlit

/-
Another attempt?
-/
/-
mutual inductive duration_expr, time_expr
with duration_expr : Π(K : Type u) [field K] [inhabited K], Type (u+1)
| zero : duration_expr
| one : duration_expr
| lit {f : fm K TIME} {sp : spc K f} (v : duration sp) : duration_expr
| var {f : fm K TIME} {sp : spc K f} (v : duration_var sp) : duration_expr
| add_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| neg_dur (d : duration_expr) : duration_expr
| sub_dur_dur (d1 : duration_expr) (d2 : duration_expr) : duration_expr
| sub_time_time (t1 : time_expr K) (t2 : time_expr K) : duration_expr
| smul_dur (k : K) (d : duration_expr) : duration_expr
with time_expr : Π(K : Type u) [field K] [inhabited K], Type (u+1)
| lit {f : fm K TIME} {sp : spc K f} (p : time sp) : time_expr K
| var {f : fm K TIME} {sp : spc K f} (v : time_var sp) : time_expr K
| add_dur_time (d : duration_expr) (t : time_expr K) : time_expr K
-/

abbreviation duration_env {f : fm K TIME} (sp : spc K f) :=
  duration_var sp → duration sp

abbreviation duration_eval  {f : fm K TIME} (sp : spc K f)  :=
  duration_env sp → duration_expr → duration sp

abbreviation time_env  {f : fm K TIME} (sp : spc K f)  :=
  time_var sp → time sp

abbreviation time_eval  {f : fm K TIME} (sp : spc K f)  :=
  time_env sp → time_expr → time sp

structure time_frame_var extends var

inductive time_frame_expr : Type  --{f : fm K T}
| lit (f : fm K TIME) : time_frame_expr
/-
It's potentially even more debatable what the parameters to the derived constructor should be,
as compared to time_expr_current.lean
-/
| derived (o : time_expr) (b : duration_expr) : time_frame_expr

--Again, same problem as "current" version of lang. Parameter f contains all of the information,
--So the variable is essentially pointless
structure time_space_var (f : fm K TIME) extends var

inductive time_space_expr : Type
| lit {f : fm K TIME} (sp : spc K f) : time_space_expr
| mk (f : time_frame_expr) : time_space_expr

abbreviation time_frame_env :=
  time_frame_var → fm K TIME
abbreviation time_frame_eval :=
  time_frame_env → time_frame_expr → fm K TIME

abbreviation time_space_env (f : fm K TIME) :=
  time_space_var f → spc K f
abbreviation time_space_eval (f : fm K TIME) :=
  time_space_env f → time_space_expr → spc K f

notation `[`flit`]` := time_frame_expr.lit flit
notation `[`slit`]` := time_space_expr.lit slit
/-
Analogous methods provided at math layer
-/
#check mk_frame
def mk_time_frame_expr (o : time_expr) (b : duration_expr) : time_frame_expr :=
  time_frame_expr.derived o b

#check mk_space
def mk_time_space_expr (K : Type u) [field K] [inhabited K] (f : time_frame_expr) : time_space_expr :=
  time_space_expr.mk f

/-
Duration expressions: add dur dur, smul scal dur
-/

def add_dur_expr_dur_expr (v1 v2 : duration_expr) : duration_expr :=
  duration_expr.add_dur_dur v1 v2

--variables {T : Type u} [field T] [inhabited T] (k : T) (dd : duration_expr)
/-
#check (λx:ℕ, dd)
def stdlit := duration_expr.lit (mk_duration (time_std_space K) 1)
#check duration_expr.smul_dur (1:K) (stdlit)
#check duration_expr

def smul_dur_expr {K : Type u} [field K] [inhabited K] (k : K) (dur_type : Type (u+1)) (dur_val : dur_type) (is_dur : dur_type = duration_expr) : duration_expr :=
begin
  simp [is_dur] at dur_val,
  exact duration_expr.smul_dur k dur_val
end

variables (my_expr : duration_expr) (kk : K)
def duration_expr1 := smul_dur_expr kk duration_expr my_expr rfl
-/
/-
type mismatch at application
  smul_dur_expr kk my_expr
term
  my_expr
has type
  lang.time.duration_expr.{u_2} : Type (u_2+1)
but is expected to have type
  lang.time.duration_expr.{u} : Type (u+1)
All Messages (76)
-/

--#check my_expr        -- duration_expr
--#check @duration_expr  -- Type (u_3+1)
--#check @smul_dur_expr
/-
Π {K : Type u} [_inst_5 : field K] [_inst_6 : inhabited K],
   K → duration_expr → duration_expr
-/

def expr1 := duration_expr.zero

def expr2 := duration_expr.lit (mk_duration (time_std_space ℚ) 4)

#check expr2

def expr3 := duration_expr.smul_dur (1:ℚ) expr2

def neg_dur_expr (v : duration_expr) : duration_expr :=
    duration_expr.neg_dur v

def sub_dur_expr_dur_expr (v1 v2 : duration_expr) : duration_expr :=    -- v1-v2
    duration_expr.sub_dur_dur v1 v2

-- See unframed file for template for proving vector_space

instance has_add_dur_expr : has_add (duration_expr) := ⟨ add_dur_expr_dur_expr ⟩
lemma add_assoc_dur_expr : ∀ a b c : duration_expr, a + b + c = a + (b + c) := sorry
instance add_semigroup_dur_expr : add_semigroup (duration_expr) := ⟨ add_dur_expr_dur_expr, add_assoc_dur_expr⟩

def dur_expr_zero  := duration_expr.zero
instance has_zero_dur_expr : has_zero (duration_expr) := ⟨dur_expr_zero⟩

--option class.instance_max_depth
--set_option trace.class_instances true

lemma zero_add_dur_expr : ∀ a : duration_expr, (0:duration_expr) + a = a := sorry
lemma add_zero_dur_expr : ∀ a : duration_expr, a + 0 = a := sorry
instance add_monoid_dur_expr {f : fm K TIME} {sp : spc K f} : add_monoid (duration_expr) := ⟨
    -- add_semigroup
    add_dur_expr_dur_expr,
    add_assoc_dur_expr,
    -- has_zero
    dur_expr_zero,
    -- new structure
    zero_add_dur_expr,
    add_zero_dur_expr
⟩

instance has_neg_dur_expr : has_neg (duration_expr) := ⟨neg_dur_expr⟩
instance has_sub_dur_expr : has_sub (duration_expr) := ⟨ sub_dur_expr_dur_expr⟩
lemma sub_eq_add_neg_dur_expr : ∀ a b : duration_expr, a - b = a + -b := sorry
instance sub_neg_monoid_dur_expr : sub_neg_monoid (duration_expr) := ⟨
    add_dur_expr_dur_expr, add_assoc_dur_expr, dur_expr_zero,
    zero_add_dur_expr,
    add_zero_dur_expr, -- add_monoid
    neg_dur_expr,                                                                  -- has_neg
    sub_dur_expr_dur_expr,                                                              -- has_sub
    sub_eq_add_neg_dur_expr,                                                       -- new
⟩

lemma add_left_neg_dur_expr : ∀ a : duration_expr, -a + a = 0 := sorry
instance : add_group (duration_expr) := ⟨
    -- sub_neg_monoid
    add_dur_expr_dur_expr, add_assoc_dur_expr, dur_expr_zero, zero_add_dur_expr, add_zero_dur_expr, -- add_monoid
    neg_dur_expr,                                                                  -- has_neg
    sub_dur_expr_dur_expr,                                                              -- has_sub
    sub_eq_add_neg_dur_expr,
    -- new
    add_left_neg_dur_expr,
⟩

lemma add_comm_dur_expr : ∀ a b : duration_expr, a + b = b + a := sorry
instance add_comm_semigroup_dur_expr : add_comm_semigroup (duration_expr) := ⟨
    -- add_semigroup
    add_dur_expr_dur_expr,
    add_assoc_dur_expr,
    add_comm_dur_expr,
⟩

instance add_comm_monoid_dur_expr : add_comm_monoid (duration_expr) := ⟨
-- add_monoid
    -- add_semigroup
    add_dur_expr_dur_expr,
    add_assoc_dur_expr,
    -- has_zero
    dur_expr_zero,
    -- new structure
    zero_add_dur_expr,
    add_zero_dur_expr,
-- add_comm_semigroup (minus repeats)
    add_comm_dur_expr,
⟩

instance has_scalar_dur_expr /- {K : Type u} [field K] [inhabited K]-/: has_scalar K duration_expr := ⟨
duration_expr.smul_dur
⟩

variables (v : K) (d : duration_expr)

#check v • d

lemma one_smul_dur_expr
  {K : Type u} [field K] [inhabited K] [has_scalar K duration_expr] : ∀ b : duration_expr,
    --(smul_dur_expr K) 1 b = b := sorry
    (1 : K) • b = b := sorry
lemma mul_smul_dur_expr : ∀ (x y : K) (b : duration_expr), (x * y) • b = x • y • b := sorry
instance mul_action_dur_expr  : mul_action K (duration_expr) := ⟨
one_smul_dur_expr,
mul_smul_dur_expr,
⟩

lemma smul_add_dur_expr : ∀(r : K) (x y : duration_expr), r • (x + y) = r • x + r • y := sorry
lemma smul_zero_dur_expr : ∀(r : K), r • (0 : duration_expr) = 0 := sorry
instance distrib_mul_action_K_dur_exprKx : distrib_mul_action K (duration_expr) := ⟨
smul_add_dur_expr,
smul_zero_dur_expr,
⟩

-- renaming vs template due to clash with name "s" for prevailing variable
lemma add_smul_dur_expr : ∀ (a b : K) (x : duration_expr), (a + b) • x = a • x + b • x := sorry
lemma zero_smul_dur_expr : ∀ (x : duration_expr), (0 : K) • x = 0 := sorry
instance semimodule_K_durationK : semimodule K (duration_expr) := ⟨ add_smul_dur_expr, zero_smul_dur_expr⟩

instance add_comm_group_dur_expr : add_comm_group (duration_expr) := ⟨
-- add_group
    add_dur_expr_dur_expr, add_assoc_dur_expr, dur_expr_zero, zero_add_dur_expr, add_zero_dur_expr, -- add_monoid
    neg_dur_expr,                                                                  -- has_neg
    sub_dur_expr_dur_expr,                                                              -- has_sub
    sub_eq_add_neg_dur_expr,
    add_left_neg_dur_expr,
-- commutativity
    add_comm_dur_expr,
⟩

instance : vector_space K (duration_expr) := sorry

/-
    ********************
    *** Affine space ***
    ********************
-/

/-
Affine operations
-/
instance : has_add (duration_expr) := ⟨add_dur_expr_dur_expr⟩
instance : has_zero (duration_expr) := ⟨dur_expr_zero⟩
instance : has_neg (duration_expr) := ⟨neg_dur_expr⟩

/-
Lemmas needed to implement affine space API
-/

def sub_time_expr_time_expr {f : fm K TIME} {sp : spc K f } (p1 p2 : time_expr) : duration_expr :=
    duration_expr.sub_time_time p1 p2
def add_time_expr_dur_expr {f : fm K TIME} {sp : spc K f } (p : time_expr) (v : duration_expr) : time_expr :=
    time_expr.add_dur_time v p
def add_dur_expr_time_expr {f : fm K TIME} {sp : spc K f } (v : duration_expr) (p : time_expr) : time_expr :=
    time_expr.add_dur_time v p

--def aff_dur_expr_group_action : duration_expr → time_expr → time_expr := add_dur_expr_time_expr
instance : has_vadd (duration_expr) (time_expr) := ⟨time_expr.add_dur_time⟩

lemma zero_dur_expr_vadd'_a1 : ∀ p : time_expr, (0 : duration_expr) +ᵥ p = p := sorry
lemma dur_expr_add_assoc'_a1 : ∀ (g1 g2 : duration_expr) (p : time_expr), g1 +ᵥ (g2 +ᵥ p) = (g1 + g2) +ᵥ p := sorry
instance dur_expr_add_action: add_action (duration_expr) (time_expr) :=
⟨ time_expr.add_dur_time, zero_dur_expr_vadd'_a1, dur_expr_add_assoc'_a1 ⟩

--def aff_time_expr_group_sub : time_expr → time_expr → duration_expr := sub_time_expr_time_expr
instance time_expr_has_vsub : has_vsub (duration_expr) (time_expr) := ⟨ duration_expr.sub_time_time ⟩

instance hm : nonempty (time_expr) := ⟨time_expr.lit (mk_time sp  1)⟩

def pp: nonempty (time_expr) := ⟨time_expr.lit (mk_time sp  1)⟩

def checkthis [nonempty (time_expr)] : time_expr := time_expr.lit (mk_time sp  1)

lemma time_expr_vsub_vadd_a1 : ∀ (p1 p2 : (time_expr)), (p1 -ᵥ p2) +ᵥ p2 = p1 := sorry
lemma time_expr_vadd_vsub_a1 : ∀ (g : duration_expr) (p : time_expr), g +ᵥ p -ᵥ p = g := sorry
instance aff_time_expr_torsor [nonempty (time_expr)] : add_torsor (duration_expr) (time_expr) :=
⟨
    time_expr.add_dur_time,
    zero_dur_expr_vadd'_a1,    -- add_action
    dur_expr_add_assoc'_a1,   -- add_action
    duration_expr.sub_time_time,    -- has_vsub
    time_expr_vsub_vadd_a1,     -- add_torsor
    time_expr_vadd_vsub_a1,     -- add_torsor
⟩

/-
+  : d s -> d s -> d s
•  : K -> d s -> d s
+ᵥ : d s -> t s -> t s
-ᵥ : t s -> t s -> d s

Here s is an affine coordinate
space on TIME. Otherwise we've
got time points and durations,
within, but not across, spaces.
-/

/-
Transform
-/
structure transform_var {K : Type u} [field K] [inhabited K]
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2) extends var

/-
invalid occurrence of recursive arg#7 of 'lang.time.transform_expr.compose', the body of the functional type depends on it.
All Messages (28)
-/
inductive transform_expr -- {K : Type u} [field K] [inhabited K]
  --{f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2:=sp1 : spc K f2)
 -- (sp1 : Σf1 : fm K TIME, spc K f1)  (sp2 : Σf2 : fm K TIME, spc K f2 := sp1)
  : Type 1
| lit {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2}
  (p : time_transform sp1 sp2) : transform_expr -- sp1 sp2
| var {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2}
  (v : transform_var sp1 sp2) : transform_expr --sp1 sp2
| apply_duration {f1 : fm K TIME} {sp1 : spc K f1} {f2 : fm K TIME} {sp2 : spc K f2}
  (v : transform_expr) (d : duration_expr) : transform_expr --sp1 sp2
| compose (left : transform_expr) (right : transform_expr) : transform_expr --sp1 sp3

abbreviation transform_env
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2)  :=
  transform_var sp1 sp2 → time_transform sp1 sp2

abbreviation transform_eval
  {f1 : fm K TIME} {f2 : fm K TIME} (sp1 : spc K f1) (sp2 : spc K f2) :=
  transform_env sp1 sp2 → transform_expr → time_transform sp1 sp2

variables {f2 : fm K TIME} (sp2 : spc K f2)

structure env
  --      {f : fm K TIME} (sp : spc K f) {f2 : fm K TIME} {sp2 : spc K f2} :=
  :=
  (duration_env : Π {f : fm K TIME}, Π (sp : spc K f), duration_env sp )
  (time_env : Π {f : fm K TIME}, Π (sp : spc K f), time_env sp )
  (transform_env : Π {f1 : fm K TIME}, Π (sp1 : spc K f1), Π {f2 : fm K TIME}, Π (sp2 : spc K f2), transform_env sp1 sp2)
  (frame_env : time_frame_env)
  (space_env : Π (f : fm K TIME), time_space_env f)
open time

def p : Π {f : fm K TIME}, Π (sp : spc K f), duration_env sp :=
  λf,λsp, λv,⟨mk_vectr sp 1⟩

#check p

#check transform_env
def env.init  : env :=
  ⟨
    (λf: fm K TIME, λsp, λv, ⟨mk_vectr sp 1⟩),
    (λf: fm K TIME, λsp, λv, ⟨mk_point sp 0⟩),
    (λf: fm K TIME, λsp1, λf2, λsp2, (λv, sp1.time_tr sp2)),
    (λv, time_std_frame K),
    (λf, λv, mk_space K f)
  ⟩

structure eval :=
  (duration_eval : Π {f : fm K TIME}, Π (sp : spc K f), duration_eval sp )
  (time_eval : Π {f : fm K TIME}, Π (sp : spc K f), time_eval sp )
  (transform_eval : Π {f1 : fm K TIME}, Π (sp1 : spc K f1), Π {f2 : fm K TIME}, Π (sp2 : spc K f2), transform_eval sp1 sp2)
  (frame_eval : time_frame_eval)
  (space_eval : Π (f : fm K TIME), time_space_eval f)
def eval.init : eval :=
  ⟨
    (λf: fm K TIME, λsp, λenv_,λexpr_, ⟨mk_vectr sp 1⟩),
    (λf: fm K TIME, λsp, λenv_,λexpr_, ⟨mk_point sp 0⟩),
    (λf: fm K TIME, λsp1, λf2, λsp2, (λenv_,λexpr_, sp1.time_tr sp2 : transform_eval sp1 sp2)),
    (λenv_, λexpr_, time_std_frame K),
    (λf, λenv_, λexpr_, mk_space K f)
  ⟩
end lang.time


import mam.Cislo3

theorem na_druhou (n : Nat) : n ^ 2 = n * n := sorry


import Cdclt.Euf
import Cdclt.Array
import Cdclt.BV
import Cdclt.Quant
set_option maxRecDepth 10000
set_option maxHeartbeats 500000

open proof
open proof.sort proof.term
open rules eufRules arrayRules bvRules quantRules

def U := atom 1000
def f := const 1000 (arrowN [U, U, U])
def p2 := const 1001 boolSort
def p3 := const 1002 boolSort
def p1 := const 1003 boolSort
def c := const 1004 U
def d := const 1005 U
def a := const 1006 U
def b := const 1007 U
def let1 := (eq a b)
def let2 := (eq c d)
def let3 := (term.and p1 top)
def let4 := (term.and p2 p3)
def let5 := (term.or (term.not p1) let4)
def let6 := (eq (appN f [a, c]) (appN f [b, d]))
def let7 := (term.not let6)
def let8 := (term.or (term.not p3) let7)
def let9 := (term.not let4)
def let10 := (term.not let2)
def let11 := (term.not let1)
def let12 := (term.and let1 let2)

theorem th0 : thHolds let1 -> thHolds let2 -> thHolds let3 -> thHolds let5 -> thHolds let8 -> holds [] :=
fun lean_a0 : thHolds let1 =>
fun lean_a1 : thHolds let2 =>
fun lean_a2 : thHolds let3 =>
fun lean_a3 : thHolds let5 =>
fun lean_a4 : thHolds let8 =>
have lean_s0 : holds ([let12, let11, let10]) := @cnfAndNeg ([let1, let2])
have lean_s1 : thHolds (orN [let11, let10, let6]) :=
  (scope (fun lean_a5 : thHolds let1 =>
    (scope (fun lean_a6 : thHolds let2 =>
      let lean_s1 := @refl f
      have lean_s2 : thHolds (eq b a) := symm lean_a5
      have lean_s3 : thHolds let1 := symm lean_s2
      let lean_s4 := cong lean_s1 lean_s3
      have lean_s5 : thHolds (eq d c) := symm lean_a6
      have lean_s6 : thHolds let2 := symm lean_s5
      have lean_s7 : thHolds let6 := cong lean_s4 lean_s6
      show thHolds let6 from lean_s7
  ))))
have lean_s2 : thHolds (implies let12 let6) := liftNOrToImp lean_s1 2 let6
have lean_s3 : thHolds (term.or (term.not let12) let6) := impliesElim lean_s2
let lean_s4 := clOr lean_s3
have lean_s5 : holds ([let11, let10, let6]) := R0 lean_s0 lean_s4 let12
have lean_s6 : holds ([let6, let11, let10]) := reorder lean_s5 ([2, 0, 1])
let lean_s7 := clOr lean_a4
have lean_s8 : holds ([let9, p3]) := @cnfAndPos ([p2, p3]) 1
have lean_s9 : holds ([p3, let9]) := reorder lean_s8 ([1, 0])
let lean_s10 := clOr lean_a3
have lean_s11 : thHolds (eq let3 p1) := thTrustValid
have lean_s12 : thHolds p1 := eqResolve lean_a2 lean_s11
let lean_s13 := clAssume lean_s12
have lean_s14 : holds ([let4]) := R1 lean_s10 lean_s13 p1
have lean_s15 : holds ([p3]) := R1 lean_s9 lean_s14 let4
have lean_s16 : holds ([let7]) := R1 lean_s7 lean_s15 p3
let lean_s17 := R0 lean_s6 lean_s16 let6
let lean_s18 := clAssume lean_a1
let lean_s19 := R1 lean_s17 lean_s18 let2
let lean_s20 := clAssume lean_a0
show holds [] from R1 lean_s19 lean_s20 let1


/-
Copyright (c) 2020 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.lint.basic
import Mathlib.PostPort

namespace Mathlib

/-!
# Linter for simplification lemmas

This files defines several linters that prevent common mistakes when declaring simp lemmas:

 * `simp_nf` checks that the left-hand side of a simp lemma is not simplified by a different lemma.
 * `simp_var_head` checks that the head symbol of the left-hand side is not a variable.
 * `simp_comm` checks that commutativity lemmas are not marked as simplification lemmas.
-/

/-- `simp_lhs_rhs ty` returns the left-hand and right-hand side of a simp lemma with type `ty`. -/
-- We only detect a fixed set of simp relations here.

-- This is somewhat justified since for a custom simp relation R,

-- the simp lemma `R a b` is implicitly converted to `R a b ↔ true` as well.

/-- `simp_lhs ty` returns the left-hand side of a simp lemma with type `ty`. -/
/--
`simp_is_conditional_core ty` returns `none` if `ty` is a conditional simp
lemma, and `some lhs` otherwise.
-/
/--
`simp_is_conditional ty` returns true iff the simp lemma with type `ty` is conditional.
-/
/-- Checks whether two expressions are equal for the simplifier. That is,
they are reducibly-definitional equal, and they have the same head symbol. -/
/-- Reports declarations that are simp lemmas whose left-hand side is not in simp-normal form. -/
-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.

-- In this case, ignore the declaration if it is not a valid simp lemma by itself.

/--
This note gives you some tips to debug any errors that the simp-normal form linter raises


-- KMB's attempt at a diagonalisation argument for a contradiction.
-- Argument fails because of universe issues (exactly why it should fail)

import logic.function
import data.set.basic
universe u
universe ZFC

-- works
inductive pSurreal : Type (u+1)
| mk : ∀ α β : Type u, (α → pSurreal) → (β → pSurreal) → pSurreal

inductive Surreal : Type 1
| mk : ∀ α β : Type, (α → Surreal) → (β → Surreal) → Surreal

--constant pSurreal : Type
--#check pSurreal.mk is the closest we got to pSurreal.intro
-- we have pSurreal.rec
#check @pSurreal.rec
variable (CProp : pSurreal → Prop)
variable (CZFC : pSurreal → Type ZFC)
variable (Cu : pSurreal → Type u)
variable (CSu : pSurreal → Sort u)
variable (Ct : pSurreal → Sort*)
-- the easiest recursor, to the prop universe
variable (HProp : (Π (L R : Type*) (a : L → pSurreal) (b : R → pSurreal),
     (Π (i : L), CProp (a i)) → (Π (j : R), CProp (b j))
     → CProp (pSurreal.mk L R a b)))

-- doesn't seem possible to make the term with these universe choices.
/-variable (hZFC : (Π (L R : Type ZFC) (a : L → pSurreal) (b : R → pSurreal),
     (Π (i : L), CProp (a i)) → (Π (j : R), CProp (b j))
     → CProp (pSurreal.mk L R a b)))
-/
-- compiles fine and is surely the best
variable (Ht : (Π (L : Sort*) (R : Sort*) (a : L → pSurreal) (b : R → pSurreal),
     (Π (i : L), Ct (a i)) → (Π (j : R), Ct (b j))
     → Ct (pSurreal.mk L R a b)))

-- fails
--variable (Hu : (Π (L : Sort u) (R : Sort u) (a : L → pSurreal) (b : R → pSurreal),
--     (Π (i : L), Cu (a i)) → (Π (j : R), Cu (b j))
--     → Cu (pSurreal.mk L R a b)))

-- fails
--variable (HSu : (Π (L : Sort u) (R : Sort u) (a : L → pSurreal) (b : R → pSurreal),
--     (Π (i : L), Cu (a i)) → (Π (j : R), Cu (b j))
--     → Cu (pSurreal.mk L R a b)))

variables (Lt : Sort*) (Rt : Sort*) (at' : Lt → pSurreal) (bt : Rt → pSurreal)

-- this is just rec again
--theorem pSurreal.rec_eq :
--  (H : ∀ L R a b, C (pSurreal.rec L R a b)) (L R a b) : -- my H better
--  @pSurreal.rec C H (pSurreal.mk L R a b) = H _ L R a b (λ i, _) (λ j, _)

def pSurreal.right : pSurreal → set pSurreal :=
  @pSurreal.rec (λ x, set pSurreal) (λ L R a b h1 h2, b '' (set.univ))

theorem pSurreal.right_eq (L R a b) :
  (pSurreal.mk L R a b).right = b '' (set.univ) := rfl

example : false :=
@function.cantor_injective pSurreal (λ R, pSurreal.mk ({} : set pSurreal) (subtype R) (

/-  begin
    intro h,
    cases h,
    cases h_property,
  end
) _) $
λ R R' e,
  (pSurreal.right_eq pempty (subtype R) _ _).symm.trans $
  (congr_arg pSurreal.right e).trans (pSurreal.right_eq _ _ _ _)
-/


import Std.Tactic.Ext
import Std.Logic

set_option linter.missingDocs false

structure A (n : Nat) where
  a : Nat

example (a b : A n) : a = b ∨ True := by
  fail_if_success
    apply Or.inl; ext
  exact Or.inr trivial

structure B (n) extends A n where
  b : Nat
  h : b > 0
  i : Fin b

@[ext] structure C (n) extends B n where
  c : Nat

example (a b : C n) : a = b := by
  ext
  guard_target = a.a = b.a; admit
  guard_target = a.b = b.b; admit
  guard_target = HEq a.i b.i; admit
  guard_target = a.c = b.c; admit

open Std.Tactic.Ext
example (f g : Nat × Nat → Nat) : f = g := by
  ext ⟨x, y⟩
  guard_target = f (x, y) = g (x, y); admit

-- allow more specific ext theorems
declare_ext_theorems_for Fin
@[ext high] theorem Fin.zero_ext (a b : Fin 0) : True → a = b := by cases a.isLt
example (a b : Fin 0) : a = b := by ext; exact True.intro

def Set (α : Type u) := α → Prop
@[ext] structure LocalEquiv (α : Type u) (β : Type v) where
  source : Set α
@[ext] structure Pretrivialization {F : Type u} (proj : Z → β) extends LocalEquiv Z (β × F) where
  baseSet : Set β
  source_eq : source = baseSet ∘ proj


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Scott Morrison
-/
import category_theory.natural_isomorphism
import category_theory.eq_to_hom
import data.sum.basic

/-!
# Categories of indexed families of objects.

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

We define the pointwise category structure on indexed families of objects in a category
(and also the dependent generalization).

-/

namespace category_theory

universes w₀ w₁ w₂ v₁ v₂ u₁ u₂

variables {I : Type w₀} (C : I → Type u₁) [Π i, category.{v₁} (C i)]

/--
`pi C` gives the cartesian product of an indexed family of categories.
-/
instance pi : category.{max w₀ v₁} (Π i, C i) :=
{ hom := λ X Y, Π i, X i ⟶ Y i,
  id := λ X i, 𝟙 (X i),
  comp := λ X Y Z f g i, f i ≫ g i }

/--
This provides some assistance to typeclass search in a common situation,
which otherwise fails. (Without this `category_theory.pi.has_limit_of_has_limit_comp_eval` fails.)
-/
abbreviation pi' {I : Type v₁} (C : I → Type u₁) [Π i, category.{v₁} (C i)] :
  category.{v₁} (Π i, C i) :=
category_theory.pi C

attribute [instance] pi'

namespace pi

@[simp] lemma id_apply (X : Π i, C i) (i) : (𝟙 X : Π i, X i ⟶ X i) i = 𝟙 (X i) := rfl
@[simp] lemma comp_apply {X Y Z : Π i, C i} (f : X ⟶ Y) (g : Y ⟶ Z) (i) :
  (f ≫ g : Π i, X i ⟶ Z i) i = f i ≫ g i := rfl

/--
The evaluation functor at `i : I`, sending an `I`-indexed family of objects to the object over `i`.
-/
@[simps]
def eval (i : I) : (Π i, C i) ⥤ C i :=
{ obj := λ f, f i,
  map := λ f g α, α i, }

section
variables {J : Type w₁}

/--
Pull back an `I`-indexed family of objects to an `J`-indexed family, along a function `J → I`.
-/
@[simps]
def comap (h : J → I) : (Π i, C i) ⥤ (Π j, C (h j)) :=
{ obj := λ f i, f (h i),
  map := λ f g α i, α (h i), }

variables (I)
/--
The natural isomorphism between
pulling back a grading along the identity function,
and the identity functor. -/
@[simps]
def comap_id : comap C (id : I → I) ≅ 𝟭 (Π i, C i) :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }.

variables {I}
variables {K : Type w₂}

/--
The natural isomorphism comparing between
pulling back along two successive functions, and
pulling back along their composition
-/
@[simps]
def comap_comp (f : K → J) (g : J → I) : comap C g ⋙ comap (C ∘ g) f ≅ comap C (g ∘ f) :=
{ hom := { app := λ X b, 𝟙 (X (g (f b))) },
  inv := { app := λ X b, 𝟙 (X (g (f b))) } }

/-- The natural isomorphism between pulling back then evaluating, and just evaluating. -/
@[simps]
def comap_eval_iso_eval (h : J → I) (j : J) : comap C h ⋙ eval (C ∘ h) j ≅ eval C (h j) :=
nat_iso.of_components (λ f, iso.refl _) (by tidy)

end

section
variables {J : Type w₀} {D : J → Type u₁} [Π j, category.{v₁} (D j)]

instance sum_elim_category : Π (s : I ⊕ J), category.{v₁} (sum.elim C D s)
| (sum.inl i) := by { dsimp, apply_instance, }
| (sum.inr j) := by { dsimp, apply_instance, }

/--
The bifunctor combining an `I`-indexed family of objects with a `J`-indexed family of objects
to obtain an `I ⊕ J`-indexed family of objects.
-/
@[simps]
def sum : (Π i, C i) ⥤ (Π j, D j) ⥤ (Π s : I ⊕ J, sum.elim C D s) :=
{ obj := λ f,
  { obj := λ g s, sum.rec f g s,
    map := λ g g' α s, sum.rec (λ i, 𝟙 (f i)) α s },
  map := λ f f' α,
  { app := λ g s, sum.rec α (λ j, 𝟙 (g j)) s, }}

end

variables {C}

/-- An isomorphism between `I`-indexed objects gives an isomorphism between each
pair of corresponding components. -/
@[simps] def iso_app {X Y : Π i, C i} (f : X ≅ Y) (i : I) : X i ≅ Y i :=
⟨f.hom i, f.inv i, by { dsimp, rw [← comp_apply, iso.hom_inv_id, id_apply] },
  by { dsimp, rw [← comp_apply, iso.inv_hom_id, id_apply] }⟩

@[simp] lemma iso_app_refl (X : Π i, C i) (i : I) : iso_app (iso.refl X) i = iso.refl (X i) := rfl
@[simp] lemma iso_app_symm {X Y : Π i, C i} (f : X ≅ Y) (i : I) :
  iso_app f.symm i = (iso_app f i).symm := rfl
@[simp] lemma iso_app_trans {X Y Z : Π i, C i} (f : X ≅ Y) (g : Y ≅ Z) (i : I) :
  iso_app (f ≪≫ g) i = iso_app f i ≪≫ iso_app g i := rfl

end pi

namespace functor

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)] {A : Type u₁} [category.{u₁} A]

/--
Assemble an `I`-indexed family of functors into a functor between the pi types.
-/
@[simps]
def pi (F : Π i, C i ⥤ D i) : (Π i, C i) ⥤ (Π i, D i) :=
{ obj := λ f i, (F i).obj (f i),
  map := λ f g α i, (F i).map (α i) }

/--
Similar to `pi`, but all functors come from the same category `A`
-/
@[simps]
def pi' (f : Π i, A ⥤ C i) : A ⥤ Π i, C i :=
{ obj := λ a i, (f i).obj a,
  map := λ a₁ a₂ h i, (f i).map h, }

section eq_to_hom

@[simp] lemma eq_to_hom_proj {x x' : Π i, C i} (h : x = x') (i : I) :
  (eq_to_hom h : x ⟶ x') i = eq_to_hom (function.funext_iff.mp h i) := by { subst h, refl, }

end eq_to_hom

-- One could add some natural isomorphisms showing
-- how `functor.pi` commutes with `pi.eval` and `pi.comap`.

@[simp] lemma pi'_eval (f : Π i, A ⥤ C i) (i : I) : (pi' f) ⋙ (pi.eval C i) = f i :=
begin
  apply functor.ext; intros,
  { simp, }, { refl, }
end

/-- Two functors to a product category are equal iff they agree on every coordinate. -/
lemma pi_ext (f f' : A ⥤ Π i, C i) (h : ∀ i, f ⋙ (pi.eval C i) = f' ⋙ (pi.eval C i)) :
  f = f' :=
begin
  apply functor.ext, swap,
  { intro X, ext i, specialize h i,
    have := congr_obj h X, simpa, },
  { intros x y p, ext i, specialize h i,
    have := congr_hom h p, simpa, }
end

end functor

namespace nat_trans

variables {C}
variables {D : I → Type u₁} [∀ i, category.{v₁} (D i)]
variables {F G : Π i, C i ⥤ D i}

/--
Assemble an `I`-indexed family of natural transformations into a single natural transformation.
-/
@[simps]
def pi (α : Π i, F i ⟶ G i) : functor.pi F ⟶ functor.pi G :=
{ app := λ f i, (α i).app (f i), }

end nat_trans

end category_theory


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import algebra.group.defs
import data.fun_like.basic
import logic.embedding
import logic.equiv.set
import order.rel_classes

/-!
# Relation homomorphisms, embeddings, isomorphisms

This file defines relation homomorphisms, embeddings, isomorphisms and order embeddings and
isomorphisms.

## Main declarations

* `rel_hom`: Relation homomorphism. A `rel_hom r s` is a function `f : α → β` such that
  `r a b → s (f a) (f b)`.
* `rel_embedding`: Relation embedding. A `rel_embedding r s` is an embedding `f : α ↪ β` such that
  `r a b ↔ s (f a) (f b)`.
* `rel_iso`: Relation isomorphism. A `rel_iso r s` is an equivalence `f : α ≃ β` such that
  `r a b ↔ s (f a) (f b)`.
* `sum_lex_congr`, `prod_lex_congr`: Creates a relation homomorphism between two `sum_lex` or two
  `prod_lex` from relation homomorphisms between their arguments.

## Notation

* `→r`: `rel_hom`
* `↪r`: `rel_embedding`
* `≃r`: `rel_iso`
-/

open function

universes u v w
variables {α β γ : Type*} {r : α → α → Prop} {s : β → β → Prop} {t : γ → γ → Prop}

/-- A relation homomorphism with respect to a given pair of relations `r` and `s`
is a function `f : α → β` such that `r a b → s (f a) (f b)`. -/
@[nolint has_inhabited_instance]
structure rel_hom {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) :=
(to_fun : α → β)
(map_rel' : ∀ {a b}, r a b → s (to_fun a) (to_fun b))

infix ` →r `:25 := rel_hom

/-- `rel_hom_class F r s` asserts that `F` is a type of functions such that all `f : F`
satisfy `r a b → s (f a) (f b)`.

The relations `r` and `s` are `out_param`s since figuring them out from a goal is a higher-order
matching problem that Lean usually can't do unaided.
-/
class rel_hom_class (F : Type*) {α β : out_param $ Type*}
  (r : out_param $ α → α → Prop) (s : out_param $ β → β → Prop)
  extends fun_like F α (λ _, β) :=
(map_rel : ∀ (f : F) {a b}, r a b → s (f a) (f b))
export rel_hom_class (map_rel)

-- The free parameters `r` and `s` are `out_param`s so this is not dangerous.
attribute [nolint dangerous_instance] rel_hom_class.to_fun_like

namespace rel_hom_class

variables {F : Type*}

lemma map_inf [semilattice_inf α] [linear_order β]
  [rel_hom_class F ((<) : β → β → Prop) ((<) : α → α → Prop)]
  (a : F) (m n : β) : a (m ⊓ n) = a m ⊓ a n :=
(strict_mono.monotone $ λ x y, map_rel a).map_inf m n

lemma map_sup [semilattice_sup α] [linear_order β]
  [rel_hom_class F ((>) : β → β → Prop) ((>) : α → α → Prop)]
  (a : F) (m n : β) : a (m ⊔ n) = a m ⊔ a n :=
@map_inf (order_dual α) (order_dual β) _ _ _ _ _ _ _

protected theorem is_irrefl [rel_hom_class F r s] (f : F) : ∀ [is_irrefl β s], is_irrefl α r
| ⟨H⟩ := ⟨λ a h, H _ (map_rel f h)⟩

protected theorem is_asymm [rel_hom_class F r s] (f : F) : ∀ [is_asymm β s], is_asymm α r
| ⟨H⟩ := ⟨λ a b h₁ h₂, H _ _ (map_rel f h₁) (map_rel f h₂)⟩

protected theorem acc [rel_hom_class F r s] (f : F) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (map_rel f h) _ rfl⟩
end

protected theorem well_founded [rel_hom_class F r s] (f : F) :
  ∀ (h : well_founded s), well_founded r
| ⟨H⟩ := ⟨λ a, rel_hom_class.acc f _ (H _)⟩

end rel_hom_class

namespace rel_hom

instance : rel_hom_class (r →r s) r s :=
{ coe := λ o, o.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  map_rel := map_rel' }

/-- Auxiliary instance if `rel_hom_class.to_fun_like.to_has_coe_to_fun` isn't found -/
instance : has_coe_to_fun (r →r s) (λ _, α → β) := ⟨λ o, o.to_fun⟩

initialize_simps_projections rel_hom (to_fun → apply)

protected theorem map_rel (f : r →r s) : ∀ {a b}, r a b → s (f a) (f b) := f.map_rel'

@[simp] theorem coe_fn_mk (f : α → β) (o) :
  (@rel_hom.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_fun (f : r →r s) : (f.to_fun : α → β) = f := rfl

/-- The map `coe_fn : (r →r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r →r s) (α → β) coe_fn :=
fun_like.coe_injective

@[ext] theorem ext ⦃f g : r →r s⦄ (h : ∀ x, f x = g x) : f = g :=
fun_like.ext f g h

theorem ext_iff {f g : r →r s} : f = g ↔ ∀ x, f x = g x :=
fun_like.ext_iff

/-- Identity map is a relation homomorphism. -/
@[refl, simps] protected def id (r : α → α → Prop) : r →r r :=
⟨λ x, x, λ a b x, x⟩

/-- Composition of two relation homomorphisms is a relation homomorphism. -/
@[trans, simps] protected def comp (g : s →r t) (f : r →r s) : r →r t :=
⟨λ x, g (f x), λ a b h, g.2 (f.2 h)⟩

/-- A relation homomorphism is also a relation homomorphism between dual relations. -/
protected def swap (f : r →r s) : swap r →r swap s :=
⟨f, λ a b, f.map_rel⟩

/-- A function is a relation homomorphism from the preimage relation of `s` to `s`. -/
def preimage (f : α → β) (s : β → β → Prop) : f ⁻¹'o s →r s := ⟨f, λ a b, id⟩

end rel_hom

/-- An increasing function is injective -/
lemma injective_of_increasing (r : α → α → Prop) (s : β → β → Prop) [is_trichotomous α r]
  [is_irrefl β s] (f : α → β) (hf : ∀ {x y}, r x y → s (f x) (f y)) : injective f :=
begin
  intros x y hxy,
  rcases trichotomous_of r x y with h | h | h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this,
  exact h,
  have := hf h, rw hxy at this, exfalso, exact irrefl_of s (f y) this
end

/-- An increasing function is injective -/
lemma rel_hom.injective_of_increasing [is_trichotomous α r]
  [is_irrefl β s] (f : r →r s) : injective f :=
injective_of_increasing r s f (λ x y, f.map_rel)

-- TODO: define a `rel_iff_class` so we don't have to do all the `convert` trickery?
theorem surjective.well_founded_iff {f : α → β} (hf : surjective f)
  (o : ∀ {a b}, r a b ↔ s (f a) (f b)) : well_founded r ↔ well_founded s :=
iff.intro (begin
  refine rel_hom_class.well_founded (rel_hom.mk _ _ : s →r r),
  { exact classical.some hf.has_right_inverse },
  intros a b h, apply o.2, convert h,
  iterate 2 { apply classical.some_spec hf.has_right_inverse },
end) (rel_hom_class.well_founded (⟨f, λ _ _, o.1⟩ : r →r s))

/-- A relation embedding with respect to a given pair of relations `r` and `s`
is an embedding `f : α ↪ β` such that `r a b ↔ s (f a) (f b)`. -/
structure rel_embedding {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ↪ β :=
(map_rel_iff' : ∀ {a b}, s (to_embedding a) (to_embedding b) ↔ r a b)

infix ` ↪r `:25 := rel_embedding

/-- The induced relation on a subtype is an embedding under the natural inclusion. -/
definition subtype.rel_embedding {X : Type*} (r : X → X → Prop) (p : X → Prop) :
  ((subtype.val : subtype p → X) ⁻¹'o r) ↪r r :=
⟨embedding.subtype p, λ x y, iff.rfl⟩

theorem preimage_equivalence {α β} (f : α → β) {s : β → β → Prop}
  (hs : equivalence s) : equivalence (f ⁻¹'o s) :=
⟨λ a, hs.1 _, λ a b h, hs.2.1 h, λ a b c h₁ h₂, hs.2.2 h₁ h₂⟩

namespace rel_embedding

/-- A relation embedding is also a relation homomorphism -/
def to_rel_hom (f : r ↪r s) : (r →r s) :=
{ to_fun := f.to_embedding.to_fun,
  map_rel' := λ x y, (map_rel_iff' f).mpr }

instance : has_coe (r ↪r s) (r →r s) := ⟨to_rel_hom⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ↪r s) (λ _, α → β) := ⟨λ o, o.to_embedding⟩

-- TODO: define and instantiate a `rel_embedding_class` when `embedding_like` is defined
instance : rel_hom_class (r ↪r s) r s :=
{ coe := coe_fn,
  coe_injective' := λ f g h, by { rcases f with ⟨⟨⟩⟩, rcases g with ⟨⟨⟩⟩, congr' },
  map_rel := λ f a b, iff.mpr (map_rel_iff' f) }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def simps.apply (h : r ↪r s) : α → β := h

initialize_simps_projections rel_embedding (to_embedding_to_fun → apply, -to_embedding)

@[simp] lemma to_rel_hom_eq_coe (f : r ↪r s) : f.to_rel_hom = f := rfl

@[simp] lemma coe_coe_fn (f : r ↪r s) : ((f : r →r s) : α → β) = f := rfl

theorem injective (f : r ↪r s) : injective f := f.inj'

theorem map_rel_iff (f : r ↪r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ↪ β) (o) :
  (@rel_embedding.mk _ _ r s f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_embedding (f : r ↪r s) : (f.to_embedding : α → β) = f := rfl

/-- The map `coe_fn : (r ↪r s) → (α → β)` is injective. -/
theorem coe_fn_injective : @function.injective (r ↪r s) (α → β) coe_fn := fun_like.coe_injective

@[ext] theorem ext ⦃f g : r ↪r s⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext _ _ h

theorem ext_iff {f g : r ↪r s} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

/-- Identity map is a relation embedding. -/
@[refl, simps] protected def refl (r : α → α → Prop) : r ↪r r :=
⟨embedding.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation embeddings is a relation embedding. -/
@[trans] protected def trans (f : r ↪r s) (g : s ↪r t) : r ↪r t :=
⟨f.1.trans g.1, λ a b, by simp [f.map_rel_iff, g.map_rel_iff]⟩

instance (r : α → α → Prop) : inhabited (r ↪r r) := ⟨rel_embedding.refl _⟩

theorem trans_apply (f : r ↪r s) (g : s ↪r t) (a : α) : (f.trans g) a = g (f a) := rfl

@[simp] theorem coe_trans (f : r ↪r s) (g : s ↪r t) : ⇑(f.trans g) = g ∘ f := rfl

/-- A relation embedding is also a relation embedding between dual relations. -/
protected def swap (f : r ↪r s) : swap r ↪r swap s :=
⟨f.to_embedding, λ a b, f.map_rel_iff⟩

/-- If `f` is injective, then it is a relation embedding from the
  preimage relation of `s` to `s`. -/
def preimage (f : α ↪ β) (s : β → β → Prop) : f ⁻¹'o s ↪r s := ⟨f, λ a b, iff.rfl⟩

theorem eq_preimage (f : r ↪r s) : r = f ⁻¹'o s :=
by { ext a b, exact f.map_rel_iff.symm }

protected theorem is_irrefl (f : r ↪r s) [is_irrefl β s] : is_irrefl α r :=
⟨λ a, mt f.map_rel_iff.2 (irrefl (f a))⟩

protected theorem is_refl (f : r ↪r s) [is_refl β s] : is_refl α r :=
⟨λ a, f.map_rel_iff.1 $ refl _⟩

protected theorem is_symm (f : r ↪r s) [is_symm β s] : is_symm α r :=
⟨λ a b, imp_imp_imp f.map_rel_iff.2 f.map_rel_iff.1 symm⟩

protected theorem is_asymm (f : r ↪r s) [is_asymm β s] : is_asymm α r :=
⟨λ a b h₁ h₂, asymm (f.map_rel_iff.2 h₁) (f.map_rel_iff.2 h₂)⟩

protected theorem is_antisymm : ∀ (f : r ↪r s) [is_antisymm β s], is_antisymm α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b h₁ h₂, f.inj' (H _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_trans : ∀ (f : r ↪r s) [is_trans β s], is_trans α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b c h₁ h₂, o.1 (H _ _ _ (o.2 h₁) (o.2 h₂))⟩

protected theorem is_total : ∀ (f : r ↪r s) [is_total β s], is_total α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o o).1 (H _ _)⟩

protected theorem is_preorder : ∀ (f : r ↪r s) [is_preorder β s], is_preorder α r
| f H := by exactI {..f.is_refl, ..f.is_trans}

protected theorem is_partial_order : ∀ (f : r ↪r s) [is_partial_order β s], is_partial_order α r
| f H := by exactI {..f.is_preorder, ..f.is_antisymm}

protected theorem is_linear_order : ∀ (f : r ↪r s) [is_linear_order β s], is_linear_order α r
| f H := by exactI {..f.is_partial_order, ..f.is_total}

protected theorem is_strict_order : ∀ (f : r ↪r s) [is_strict_order β s], is_strict_order α r
| f H := by exactI {..f.is_irrefl, ..f.is_trans}

protected theorem is_trichotomous : ∀ (f : r ↪r s) [is_trichotomous β s], is_trichotomous α r
| ⟨f, o⟩ ⟨H⟩ := ⟨λ a b, (or_congr o (or_congr f.inj'.eq_iff o)).1 (H _ _)⟩

protected theorem is_strict_total_order' :
  ∀ (f : r ↪r s) [is_strict_total_order' β s], is_strict_total_order' α r
| f H := by exactI {..f.is_trichotomous, ..f.is_strict_order}

protected theorem acc (f : r ↪r s) (a : α) : acc s (f a) → acc r a :=
begin
  generalize h : f a = b, intro ac,
  induction ac with _ H IH generalizing a, subst h,
  exact ⟨_, λ a' h, IH (f a') (f.map_rel_iff.2 h) _ rfl⟩
end

protected theorem well_founded : ∀ (f : r ↪r s) (h : well_founded s), well_founded r
| f ⟨H⟩ := ⟨λ a, f.acc _ (H _)⟩

protected theorem is_well_order : ∀ (f : r ↪r s) [is_well_order β s], is_well_order α r
| f H := by exactI {wf := f.well_founded H.wf, ..f.is_strict_total_order'}

/--
To define an relation embedding from an antisymmetric relation `r` to a reflexive relation `s` it
suffices to give a function together with a proof that it satisfies `s (f a) (f b) ↔ r a b`.
-/
def of_map_rel_iff (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) : r ↪r s :=
{ to_fun := f,
  inj' := λ x y h, antisymm ((hf _ _).1 (h ▸ refl _)) ((hf _ _).1 (h ▸ refl _)),
  map_rel_iff' := hf }

@[simp]
lemma of_map_rel_iff_coe (f : α → β) [is_antisymm α r] [is_refl β s]
  (hf : ∀ a b, s (f a) (f b) ↔ r a b) :
  ⇑(of_map_rel_iff f hf : r ↪r s) = f :=
rfl

/-- It suffices to prove `f` is monotone between strict relations
  to show it is a relation embedding. -/
def of_monotone [is_trichotomous α r] [is_asymm β s] (f : α → β)
  (H : ∀ a b, r a b → s (f a) (f b)) : r ↪r s :=
begin
  haveI := @is_asymm.is_irrefl β s _,
  refine ⟨⟨f, λ a b e, _⟩, λ a b, ⟨λ h, _, H _ _⟩⟩,
  { refine ((@trichotomous _ r _ a b).resolve_left _).resolve_right _;
    exact λ h, @irrefl _ s _ _ (by simpa [e] using H _ _ h) },
  { refine (@trichotomous _ r _ a b).resolve_right (or.rec (λ e, _) (λ h', _)),
    { subst e, exact irrefl _ h },
    { exact asymm (H _ _ h') h } }
end

@[simp] theorem of_monotone_coe [is_trichotomous α r] [is_asymm β s] (f : α → β) (H) :
  (@of_monotone _ _ r s _ _ f H : α → β) = f := rfl

end rel_embedding

/-- A relation isomorphism is an equivalence that is also a relation embedding. -/
structure rel_iso {α β : Type*} (r : α → α → Prop) (s : β → β → Prop) extends α ≃ β :=
(map_rel_iff' : ∀ {a b}, s (to_equiv a) (to_equiv b) ↔ r a b)

infix ` ≃r `:25 := rel_iso

namespace rel_iso

/-- Convert an `rel_iso` to an `rel_embedding`. This function is also available as a coercion
but often it is easier to write `f.to_rel_embedding` than to write explicitly `r` and `s`
in the target type. -/
def to_rel_embedding (f : r ≃r s) : r ↪r s :=
⟨f.to_equiv.to_embedding, f.map_rel_iff'⟩

theorem to_equiv_injective : injective (to_equiv : (r ≃r s) → α ≃ β)
| ⟨e₁, o₁⟩ ⟨e₂, o₂⟩ h := by { congr, exact h }

instance : has_coe (r ≃r s) (r ↪r s) := ⟨to_rel_embedding⟩
-- see Note [function coercion]
instance : has_coe_to_fun (r ≃r s) (λ _, α → β) := ⟨λ f, f⟩

-- TODO: define and instantiate a `rel_iso_class` when `equiv_like` is defined
instance : rel_hom_class (r ≃r s) r s :=
{ coe := coe_fn,
  coe_injective' := equiv.coe_fn_injective.comp to_equiv_injective,
  map_rel := λ f a b, iff.mpr (map_rel_iff' f) }

@[simp] lemma to_rel_embedding_eq_coe (f : r ≃r s) : f.to_rel_embedding = f := rfl

@[simp] lemma coe_coe_fn (f : r ≃r s) : ((f : r ↪r s) : α → β) = f := rfl

theorem map_rel_iff (f : r ≃r s) : ∀ {a b}, s (f a) (f b) ↔ r a b := f.map_rel_iff'

@[simp] theorem coe_fn_mk (f : α ≃ β) (o : ∀ ⦃a b⦄, s (f a) (f b) ↔ r a b) :
  (rel_iso.mk f o : α → β) = f := rfl

@[simp] theorem coe_fn_to_equiv (f : r ≃r s) : (f.to_equiv : α → β) = f := rfl

/-- The map `coe_fn : (r ≃r s) → (α → β)` is injective. Lean fails to parse
`function.injective (λ e : r ≃r s, (e : α → β))`, so we use a trick to say the same. -/
theorem coe_fn_injective : @function.injective (r ≃r s) (α → β) coe_fn := fun_like.coe_injective

@[ext] theorem ext ⦃f g : r ≃r s⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

theorem ext_iff {f g : r ≃r s} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

/-- Inverse map of a relation isomorphism is a relation isomorphism. -/
@[symm] protected def symm (f : r ≃r s) : s ≃r r :=
⟨f.to_equiv.symm, λ a b, by erw [← f.map_rel_iff, f.1.apply_symm_apply, f.1.apply_symm_apply]⟩

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : r ≃r s) : α → β := h
/-- See Note [custom simps projection]. -/
def simps.symm_apply (h : r ≃r s) : β → α := h.symm

initialize_simps_projections rel_iso
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

/-- Identity map is a relation isomorphism. -/
@[refl, simps apply] protected def refl (r : α → α → Prop) : r ≃r r :=
⟨equiv.refl _, λ a b, iff.rfl⟩

/-- Composition of two relation isomorphisms is a relation isomorphism. -/
@[trans, simps apply] protected def trans (f₁ : r ≃r s) (f₂ : s ≃r t) : r ≃r t :=
⟨f₁.to_equiv.trans f₂.to_equiv, λ a b, f₂.map_rel_iff.trans f₁.map_rel_iff⟩

instance (r : α → α → Prop) : inhabited (r ≃r r) := ⟨rel_iso.refl _⟩

@[simp] lemma default_def (r : α → α → Prop) : default = rel_iso.refl r := rfl

/-- a relation isomorphism is also a relation isomorphism between dual relations. -/
protected def swap (f : r ≃r s) : (swap r) ≃r (swap s) :=
⟨f.to_equiv, λ _ _, f.map_rel_iff⟩

@[simp] theorem coe_fn_symm_mk (f o) : ((@rel_iso.mk _ _ r s f o).symm : β → α) = f.symm :=
rfl

@[simp] theorem apply_symm_apply (e : r ≃r s) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_symm_apply x

@[simp] theorem symm_apply_apply (e : r ≃r s) (x : α) : e.symm (e x) = x :=
e.to_equiv.symm_apply_apply x

theorem rel_symm_apply (e : r ≃r s) {x y} : r x (e.symm y) ↔ s (e x) y :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

theorem symm_apply_rel (e : r ≃r s) {x y} : r (e.symm x) y ↔ s x (e y) :=
by rw [← e.map_rel_iff, e.apply_symm_apply]

protected lemma bijective (e : r ≃r s) : bijective e := e.to_equiv.bijective
protected lemma injective (e : r ≃r s) : injective e := e.to_equiv.injective
protected lemma surjective (e : r ≃r s) : surjective e := e.to_equiv.surjective

@[simp] lemma range_eq (e : r ≃r s) : set.range e = set.univ := e.surjective.range_eq

@[simp] lemma eq_iff_eq (f : r ≃r s) {a b} : f a = f b ↔ a = b :=
f.injective.eq_iff

/-- Any equivalence lifts to a relation isomorphism between `s` and its preimage. -/
protected def preimage (f : α ≃ β) (s : β → β → Prop) : f ⁻¹'o s ≃r s := ⟨f, λ a b, iff.rfl⟩

/-- A surjective relation embedding is a relation isomorphism. -/
@[simps apply]
noncomputable def of_surjective (f : r ↪r s) (H : surjective f) : r ≃r s :=
⟨equiv.of_bijective f ⟨f.injective, H⟩, λ a b, f.map_rel_iff⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the sum.
-/
def sum_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  sum.lex r₁ r₂ ≃r sum.lex s₁ s₂ :=
⟨equiv.sum_congr e₁.to_equiv e₂.to_equiv, λ a b,
 by cases e₁ with f hf; cases e₂ with g hg;
    cases a; cases b; simp [hf, hg]⟩

/--
Given relation isomorphisms `r₁ ≃r s₁` and `r₂ ≃r s₂`, construct a relation isomorphism for the
lexicographic orders on the product.
-/
def prod_lex_congr {α₁ α₂ β₁ β₂ r₁ r₂ s₁ s₂}
  (e₁ : @rel_iso α₁ β₁ r₁ s₁) (e₂ : @rel_iso α₂ β₂ r₂ s₂) :
  prod.lex r₁ r₂ ≃r prod.lex s₁ s₂ :=
⟨equiv.prod_congr e₁.to_equiv e₂.to_equiv,
  λ a b, by simp [prod.lex_def, e₁.map_rel_iff, e₂.map_rel_iff]⟩

instance : group (r ≃r r) :=
{ one := rel_iso.refl r,
  mul := λ f₁ f₂, f₂.trans f₁,
  inv := rel_iso.symm,
  mul_assoc := λ f₁ f₂ f₃, rfl,
  one_mul := λ f, ext $ λ _, rfl,
  mul_one := λ f, ext $ λ _, rfl,
  mul_left_inv := λ f, ext f.symm_apply_apply }

@[simp] lemma coe_one : ⇑(1 : r ≃r r) = id := rfl

@[simp] lemma coe_mul (e₁ e₂ : r ≃r r) : ⇑(e₁ * e₂) = e₁ ∘ e₂ := rfl

lemma mul_apply (e₁ e₂ : r ≃r r) (x : α) : (e₁ * e₂) x = e₁ (e₂ x) := rfl

@[simp] lemma inv_apply_self (e : r ≃r r) (x) : e⁻¹ (e x) = x := e.symm_apply_apply x

@[simp] lemma apply_inv_self (e : r ≃r r) (x) : e (e⁻¹ x) = x := e.apply_symm_apply x

end rel_iso

/-- `subrel r p` is the inherited relation on a subset. -/
def subrel (r : α → α → Prop) (p : set α) : p → p → Prop :=
(coe : p → α) ⁻¹'o r

@[simp] theorem subrel_val (r : α → α → Prop) (p : set α)
  {a b} : subrel r p a b ↔ r a.1 b.1 := iff.rfl

namespace subrel

/-- The relation embedding from the inherited relation on a subset. -/
protected def rel_embedding (r : α → α → Prop) (p : set α) :
  subrel r p ↪r r := ⟨embedding.subtype _, λ a b, iff.rfl⟩

@[simp] theorem rel_embedding_apply (r : α → α → Prop) (p a) :
  subrel.rel_embedding r p a = a.1 := rfl

instance (r : α → α → Prop) [is_well_order α r] (p : set α) : is_well_order p (subrel r p) :=
rel_embedding.is_well_order (subrel.rel_embedding r p)

instance (r : α → α → Prop) [is_refl α r] (p : set α) : is_refl p (subrel r p) :=
⟨λ x, @is_refl.refl α r _ x⟩

instance (r : α → α → Prop) [is_symm α r] (p : set α) : is_symm p (subrel r p) :=
⟨λ x y, @is_symm.symm α r _ x y⟩

instance (r : α → α → Prop) [is_trans α r] (p : set α) : is_trans p (subrel r p) :=
⟨λ x y z, @is_trans.trans α r _ x y z⟩

instance (r : α → α → Prop) [is_irrefl α r] (p : set α) : is_irrefl p (subrel r p) :=
⟨λ x, @is_irrefl.irrefl α r _ x⟩

end subrel

/-- Restrict the codomain of a relation embedding. -/
def rel_embedding.cod_restrict (p : set β) (f : r ↪r s) (H : ∀ a, f a ∈ p) : r ↪r subrel s p :=
⟨f.to_embedding.cod_restrict p H, f.map_rel_iff'⟩

@[simp] theorem rel_embedding.cod_restrict_apply (p) (f : r ↪r s) (H a) :
  rel_embedding.cod_restrict p f H a = ⟨f a, H a⟩ := rfl


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.types
import Mathlib.category_theory.equivalence
import Mathlib.data.opposite
import Mathlib.PostPort

universes v₁ u₁ u₂ v₂ v

namespace Mathlib

namespace category_theory

/-- The hom types of the opposite of a category (or graph).

  As with the objects, we'll make this irreducible below.
  Use `f.op` and `f.unop` to convert between morphisms of C
  and morphisms of Cᵒᵖ.
-/
protected instance has_hom.opposite {C : Type u₁} [has_hom C] : has_hom (Cᵒᵖ) :=
  has_hom.mk fun (X Y : Cᵒᵖ) => opposite.unop Y ⟶ opposite.unop X

/--
The opposite of a morphism in `C`.
-/
/--
def has_hom.hom.op {C : Type u₁} [has_hom C] {X : C} {Y : C} (f : X ⟶ Y) :
    opposite.op Y ⟶ opposite.op X :=
  f

Given a morphism in `Cᵒᵖ`, we can take the "unopposite" back in `C`.
-/
def has_hom.hom.unop {C : Type u₁} [has_hom C] {X : Cᵒᵖ} {Y : Cᵒᵖ} (f : X ⟶ Y) :
    opposite.unop Y ⟶ opposite.unop X :=
  f

theorem has_hom.hom.op_inj {C : Type u₁} [has_hom C] {X : C} {Y : C} :
    function.injective has_hom.hom.op :=
  fun (_x _x_1 : X ⟶ Y) (H : has_hom.hom.op _x = has_hom.hom.op _x_1) =>
    congr_arg has_hom.hom.unop H

theorem has_hom.hom.unop_inj {C : Type u₁} [has_hom C] {X : Cᵒᵖ} {Y : Cᵒᵖ} :
    function.injective has_hom.hom.unop :=
  fun (_x _x_1 : X ⟶ Y) (H : has_hom.hom.unop _x = has_hom.hom.unop _x_1) =>
    congr_arg has_hom.hom.op H

@[simp] theorem has_hom.hom.unop_op {C : Type u₁} [has_hom C] {X : C} {Y : C} {f : X ⟶ Y} :
    has_hom.hom.unop (has_hom.hom.op f) = f :=
  rfl

@[simp] theorem has_hom.hom.op_unop {C : Type u₁} [has_hom C] {X : Cᵒᵖ} {Y : Cᵒᵖ} {f : X ⟶ Y} :
    has_hom.hom.op (has_hom.hom.unop f) = f :=
  rfl

/--
The opposite category.

See https://stacks.math.columbia.edu/tag/001M.
-/
protected instance category.opposite {C : Type u₁} [category C] : category (Cᵒᵖ) := category.mk

@[simp] theorem op_comp {C : Type u₁} [category C] {X : C} {Y : C} {Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
    has_hom.hom.op (f ≫ g) = has_hom.hom.op g ≫ has_hom.hom.op f :=
  rfl

@[simp] theorem op_id {C : Type u₁} [category C] {X : C} : has_hom.hom.op 𝟙 = 𝟙 := rfl

@[simp] theorem unop_comp {C : Type u₁} [category C] {X : Cᵒᵖ} {Y : Cᵒᵖ} {Z : Cᵒᵖ} {f : X ⟶ Y}
    {g : Y ⟶ Z} : has_hom.hom.unop (f ≫ g) = has_hom.hom.unop g ≫ has_hom.hom.unop f :=
  rfl

@[simp] theorem unop_id {C : Type u₁} [category C] {X : Cᵒᵖ} : has_hom.hom.unop 𝟙 = 𝟙 := rfl

@[simp] theorem unop_id_op {C : Type u₁} [category C] {X : C} : has_hom.hom.unop 𝟙 = 𝟙 := rfl

@[simp] theorem op_id_unop {C : Type u₁} [category C] {X : Cᵒᵖ} : has_hom.hom.op 𝟙 = 𝟙 := rfl

/-- The functor from the double-opposite of a category to the underlying category. -/
def op_op (C : Type u₁) [category C] : Cᵒᵖᵒᵖ ⥤ C :=
  functor.mk (fun (X : Cᵒᵖᵒᵖ) => opposite.unop (opposite.unop X))
    fun (X Y : Cᵒᵖᵒᵖ) (f : X ⟶ Y) => has_hom.hom.unop (has_hom.hom.unop f)

/-- The functor from a category to its double-opposite.  -/
def unop_unop (C : Type u₁) [category C] : C ⥤ (Cᵒᵖᵒᵖ) :=
  functor.mk (fun (X : C) => opposite.op (opposite.op X))
    fun (X Y : C) (f : X ⟶ Y) => has_hom.hom.op (has_hom.hom.op f)

/-- The double opposite category is equivalent to the original. -/
@[simp] theorem op_op_equivalence_inverse (C : Type u₁) [category C] :
    equivalence.inverse (op_op_equivalence C) = unop_unop C :=
  Eq.refl (equivalence.inverse (op_op_equivalence C))

/--
If `f.op` is an isomorphism `f` must be too.
(This cannot be an instance as it would immediately loop!)
-/
def is_iso_of_op {C : Type u₁} [category C] {X : C} {Y : C} (f : X ⟶ Y)
    [is_iso (has_hom.hom.op f)] : is_iso f :=
  is_iso.mk (has_hom.hom.unop (inv (has_hom.hom.op f)))

namespace functor

/--
The opposite of a functor, i.e. considering a functor `F : C ⥤ D` as a functor `Cᵒᵖ ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made between these.
-/
@[simp] theorem op_obj {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) (X : Cᵒᵖ) :
    obj (functor.op F) X = opposite.op (obj F (opposite.unop X)) :=
  Eq.refl (obj (functor.op F) X)

/--
Given a functor `F : Cᵒᵖ ⥤ Dᵒᵖ` we can take the "unopposite" functor `F : C ⥤ D`.
In informal mathematics no distinction is made between these.
-/
protected def unop {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) :
    C ⥤ D :=
  mk (fun (X : C) => opposite.unop (obj F (opposite.op X)))
    fun (X Y : C) (f : X ⟶ Y) => has_hom.hom.unop (map F (has_hom.hom.op f))

/-- The isomorphism between `F.op.unop` and `F`. -/
def op_unop_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) :
    functor.unop (functor.op F) ≅ F :=
  nat_iso.of_components (fun (X : C) => iso.refl (obj (functor.unop (functor.op F)) X)) sorry

/-- The isomorphism between `F.unop.op` and `F`. -/
def unop_op_iso {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) :
    functor.op (functor.unop F) ≅ F :=
  nat_iso.of_components (fun (X : Cᵒᵖ) => iso.refl (obj (functor.op (functor.unop F)) X)) sorry

/--
Taking the opposite of a functor is functorial.
-/
@[simp] theorem op_hom_obj (C : Type u₁) [category C] (D : Type u₂) [category D] (F : C ⥤ Dᵒᵖ) :
    obj (op_hom C D) F = functor.op (opposite.unop F) :=
  Eq.refl (obj (op_hom C D) F)

/--
Take the "unopposite" of a functor is functorial.
-/
@[simp] theorem op_inv_obj (C : Type u₁) [category C] (D : Type u₂) [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) :
    obj (op_inv C D) F = opposite.op (functor.unop F) :=
  Eq.refl (obj (op_inv C D) F)

-- TODO show these form an equivalence

/--
Another variant of the opposite of functor, turning a functor `C ⥤ Dᵒᵖ` into a functor `Cᵒᵖ ⥤ D`.
In informal mathematics no distinction is made.
-/
@[simp] theorem left_op_map {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ (Dᵒᵖ))
    (X : Cᵒᵖ) (Y : Cᵒᵖ) (f : X ⟶ Y) :
    map (functor.left_op F) f = has_hom.hom.unop (map F (has_hom.hom.unop f)) :=
  Eq.refl (map (functor.left_op F) f)

/--
Another variant of the opposite of functor, turning a functor `Cᵒᵖ ⥤ D` into a functor `C ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made.
-/
@[simp] theorem right_op_obj {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ D)
    (X : C) : obj (functor.right_op F) X = opposite.op (obj F (opposite.op X)) :=
  Eq.refl (obj (functor.right_op F) X)

-- TODO show these form an equivalence

protected instance op.category_theory.full {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} [full F] : full (functor.op F) :=
  full.mk
    fun (X Y : Cᵒᵖ) (f : obj (functor.op F) X ⟶ obj (functor.op F) Y) =>
      has_hom.hom.op (preimage F (has_hom.hom.unop f))

protected instance op.category_theory.faithful {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} [faithful F] : faithful (functor.op F) :=
  faithful.mk

/-- If F is faithful then the right_op of F is also faithful. -/
protected instance right_op_faithful {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : Cᵒᵖ ⥤ D} [faithful F] : faithful (functor.right_op F) :=
  faithful.mk

/-- If F is faithful then the left_op of F is also faithful. -/
protected instance left_op_faithful {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ (Dᵒᵖ)} [faithful F] : faithful (functor.left_op F) :=
  faithful.mk

end functor

namespace nat_trans

/-- The opposite of a natural transformation. -/
@[simp] theorem op_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (α : F ⟶ G) (X : Cᵒᵖ) : app (nat_trans.op α) X = has_hom.hom.op (app α (opposite.unop X)) :=
  Eq.refl (app (nat_trans.op α) X)

@[simp] theorem op_id {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) :
    nat_trans.op 𝟙 = 𝟙 :=
  rfl

/-- The "unopposite" of a natural transformation. -/
@[simp] theorem unop_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)}
    {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ⟶ G) (X : C) :
    app (nat_trans.unop α) X = has_hom.hom.unop (app α (opposite.op X)) :=
  Eq.refl (app (nat_trans.unop α) X)

@[simp] theorem unop_id {C : Type u₁} [category C] {D : Type u₂} [category D] (F : Cᵒᵖ ⥤ (Dᵒᵖ)) :
    nat_trans.unop 𝟙 = 𝟙 :=
  rfl

/--
Given a natural transformation `α : F.op ⟶ G.op`,
we can take the "unopposite" of each component obtaining a natural transformation `G ⟶ F`.
-/
protected def remove_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (α : functor.op F ⟶ functor.op G) : G ⟶ F :=
  mk fun (X : C) => has_hom.hom.unop (app α (opposite.op X))

@[simp] theorem remove_op_id {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) :
    nat_trans.remove_op 𝟙 = 𝟙 :=
  rfl

/--
Given a natural transformation `α : F ⟶ G`, for `F G : C ⥤ Dᵒᵖ`,
taking `unop` of each component gives a natural transformation `G.left_op ⟶ F.left_op`.
-/
protected def left_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)}
    {G : C ⥤ (Dᵒᵖ)} (α : F ⟶ G) : functor.left_op G ⟶ functor.left_op F :=
  mk fun (X : Cᵒᵖ) => has_hom.hom.unop (app α (opposite.unop X))

@[simp] theorem left_op_app {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)}
    {G : C ⥤ (Dᵒᵖ)} (α : F ⟶ G) (X : Cᵒᵖ) :
    app (nat_trans.left_op α) X = has_hom.hom.unop (app α (opposite.unop X)) :=
  rfl

/--
Given a natural transformation `α : F.left_op ⟶ G.left_op`, for `F G : C ⥤ Dᵒᵖ`,
taking `op` of each component gives a natural transformation `G ⟶ F`.
-/
protected def remove_left_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ (Dᵒᵖ)}
    {G : C ⥤ (Dᵒᵖ)} (α : functor.left_op F ⟶ functor.left_op G) : G ⟶ F :=
  mk fun (X : C) => has_hom.hom.op (app α (opposite.op X))

@[simp] theorem remove_left_op_app {C : Type u₁} [category C] {D : Type u₂} [category D]
    {F : C ⥤ (Dᵒᵖ)} {G : C ⥤ (Dᵒᵖ)} (α : functor.left_op F ⟶ functor.left_op G) (X : C) :
    app (nat_trans.remove_left_op α) X = has_hom.hom.op (app α (opposite.op X)) :=
  rfl

end nat_trans

namespace iso

/--
The opposite isomorphism.
-/
protected def op {C : Type u₁} [category C] {X : C} {Y : C} (α : X ≅ Y) :
    opposite.op Y ≅ opposite.op X :=
  mk (has_hom.hom.op (hom α)) (has_hom.hom.op (inv α))

@[simp] theorem op_hom {C : Type u₁} [category C] {X : C} {Y : C} {α : X ≅ Y} :
    hom (iso.op α) = has_hom.hom.op (hom α) :=
  rfl

@[simp] theorem op_inv {C : Type u₁} [category C] {X : C} {Y : C} {α : X ≅ Y} :
    inv (iso.op α) = has_hom.hom.op (inv α) :=
  rfl

end iso

namespace nat_iso

/-- The natural isomorphism between opposite functors `G.op ≅ F.op` induced by a natural
isomorphism between the original functors `F ≅ G`. -/
protected def op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (α : F ≅ G) : functor.op G ≅ functor.op F :=
  iso.mk (nat_trans.op (iso.hom α)) (nat_trans.op (iso.inv α))

@[simp] theorem op_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (α : F ≅ G) : iso.hom (nat_iso.op α) = nat_trans.op (iso.hom α) :=
  rfl

@[simp] theorem op_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {G : C ⥤ D}
    (α : F ≅ G) : iso.inv (nat_iso.op α) = nat_trans.op (iso.inv α) :=
  rfl

/-- The natural isomorphism between functors `G ≅ F` induced by a natural isomorphism
between the opposite functors `F.op ≅ G.op`. -/
protected def remove_op {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (α : functor.op F ≅ functor.op G) : G ≅ F :=
  iso.mk (nat_trans.remove_op (iso.hom α)) (nat_trans.remove_op (iso.inv α))

@[simp] theorem remove_op_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (α : functor.op F ≅ functor.op G) :
    iso.hom (nat_iso.remove_op α) = nat_trans.remove_op (iso.hom α) :=
  rfl

@[simp] theorem remove_op_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D}
    {G : C ⥤ D} (α : functor.op F ≅ functor.op G) :
    iso.inv (nat_iso.remove_op α) = nat_trans.remove_op (iso.inv α) :=
  rfl

/-- The natural isomorphism between functors `G.unop ≅ F.unop` induced by a natural isomorphism
between the original functors `F ≅ G`. -/
protected def unop {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)}
    {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ≅ G) : functor.unop G ≅ functor.unop F :=
  iso.mk (nat_trans.unop (iso.hom α)) (nat_trans.unop (iso.inv α))

@[simp] theorem unop_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)}
    {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ≅ G) : iso.hom (nat_iso.unop α) = nat_trans.unop (iso.hom α) :=
  rfl

@[simp] theorem unop_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : Cᵒᵖ ⥤ (Dᵒᵖ)}
    {G : Cᵒᵖ ⥤ (Dᵒᵖ)} (α : F ≅ G) : iso.inv (nat_iso.unop α) = nat_trans.unop (iso.inv α) :=
  rfl

end nat_iso

namespace equivalence

/--
An equivalence between categories gives an equivalence between the opposite categories.
-/
@[simp] theorem op_inverse {C : Type u₁} [category C] {D : Type u₂} [category D] (e : C ≌ D) :
    inverse (op e) = functor.op (inverse e) :=
  Eq.refl (inverse (op e))

/--
An equivalence between opposite categories gives an equivalence between the original categories.
-/
@[simp] theorem unop_unit_iso {C : Type u₁} [category C] {D : Type u₂} [category D]
    (e : Cᵒᵖ ≌ (Dᵒᵖ)) : unit_iso (unop e) = iso.symm (nat_iso.unop (unit_iso e)) :=
  Eq.refl (unit_iso (unop e))

end equivalence

/-- The equivalence between arrows of the form `A ⟶ B` and `B.unop ⟶ A.unop`. Useful for building
adjunctions.
Note that this (definitionally) gives variants
```
def op_equiv' (A : C) (B : Cᵒᵖ) : (opposite.op A ⟶ B) ≃ (B.unop ⟶ A) :=
op_equiv _ _

def op_equiv'' (A : Cᵒᵖ) (B : C) : (A ⟶ opposite.op B) ≃ (B ⟶ A.unop) :=
op_equiv _ _

def op_equiv''' (A B : C) : (opposite.op A ⟶ opposite.op B) ≃ (B ⟶ A) :=
op_equiv _ _
```
-/
def op_equiv {C : Type u₁} [category C] (A : Cᵒᵖ) (B : Cᵒᵖ) :
    (A ⟶ B) ≃ (opposite.unop B ⟶ opposite.unop A) :=
  equiv.mk (fun (f : A ⟶ B) => has_hom.hom.unop f)
    (fun (g : opposite.unop B ⟶ opposite.unop A) => has_hom.hom.op g) sorry sorry

-- These two are made by hand rather than by simps because simps generates

-- `(op_equiv _ _).to_fun f = ...` rather than the coercion version.

@[simp] theorem op_equiv_apply {C : Type u₁} [category C] (A : Cᵒᵖ) (B : Cᵒᵖ) (f : A ⟶ B) :
    coe_fn (op_equiv A B) f = has_hom.hom.unop f :=
  rfl

@[simp] theorem op_equiv_symm_apply {C : Type u₁} [category C] (A : Cᵒᵖ) (B : Cᵒᵖ)
    (f : opposite.unop B ⟶ opposite.unop A) :
    coe_fn (equiv.symm (op_equiv A B)) f = has_hom.hom.op f :=
  rfl

/-- Construct a morphism in the opposite of a preorder category from an inequality. -/
def op_hom_of_le {α : Type v} [preorder α] {U : αᵒᵖ} {V : αᵒᵖ}
    (h : opposite.unop V ≤ opposite.unop U) : U ⟶ V :=
  has_hom.hom.op (hom_of_le h)

theorem le_of_op_hom {α : Type v} [preorder α] {U : αᵒᵖ} {V : αᵒᵖ} (h : U ⟶ V) :
    opposite.unop V ≤ opposite.unop U :=
  le_of_hom (has_hom.hom.unop h)

end Mathlib


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel, Scott Morrison
-/
import category_theory.preadditive.yoneda.basic
import category_theory.preadditive.injective
import algebra.category.Group.epi_mono
import algebra.category.Module.epi_mono

/-!
An object is injective iff the preadditive yoneda functor on it preserves epimorphisms.
-/

universes v u

open opposite

namespace category_theory
variables {C : Type u} [category.{v} C]

section preadditive
variables [preadditive C]

namespace injective

lemma injective_iff_preserves_epimorphisms_preadditive_yoneda_obj (J : C) :
  injective J ↔ (preadditive_yoneda.obj J).preserves_epimorphisms :=
begin
  rw injective_iff_preserves_epimorphisms_yoneda_obj,
  refine ⟨λ (h : (preadditive_yoneda.obj J ⋙ (forget _)).preserves_epimorphisms), _, _⟩,
  { exactI functor.preserves_epimorphisms_of_preserves_of_reflects (preadditive_yoneda.obj J)
      (forget _) },
  { introI,
    exact (infer_instance : (preadditive_yoneda.obj J ⋙ forget _).preserves_epimorphisms) }
end

lemma injective_iff_preserves_epimorphisms_preadditive_yoneda_obj' (J : C) :
  injective J ↔ (preadditive_yoneda_obj J).preserves_epimorphisms :=
begin
  rw injective_iff_preserves_epimorphisms_yoneda_obj,
  refine ⟨λ (h : (preadditive_yoneda_obj J ⋙ (forget _)).preserves_epimorphisms), _, _⟩,
  { exactI functor.preserves_epimorphisms_of_preserves_of_reflects (preadditive_yoneda_obj J)
      (forget _) },
  { introI,
    exact (infer_instance : (preadditive_yoneda_obj J ⋙ forget _).preserves_epimorphisms) }
end

end injective

end preadditive

end category_theory


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

import tidy.lib.tactic
import tidy.lib.pretty_print

open tactic

meta def forward_attribute : user_attribute := {
  name := `forward,
  descr := "A lemma whose conclusion should be deduced whenever all arguments are satisfiable from hypotheses; use `forwards_reasoning` to automatically try all lemmas tagged `@[forward]`."
}

run_cmd attribute.register `forward_attribute

/- Improvements:

* Store the local_context, and its types, rather than recomputing.
* Give up earlier if our current expression is obviously still just a hypothesis.
* Don't use dsimplify; does it still work?
  * If not, try using whnf
* In mk_apps, `to_expr` is probably too expensive. Can we get away with just the second option?
* In the second option, `mk_app_aux`, either delete the instance implicit branch, and hope unify
  handles typeclass inference for us later, or make do typeclass inference by hand, using `apply_instance`

For testing, we better be able to run against lean-category-theory...
-/

meta def guard_no_duplicate_hypothesis (t : expr) : tactic unit :=
do hyps ← local_context,
   types ← hyps.mmap (λ h, infer_type h),
   success_if_fail (types.mfirst (λ s, is_def_eq s t))

meta def guard_prop (e : expr) : tactic unit :=
do t ← infer_type e,
   guard (t = `(Prop))

meta def attempt_forwards_reasoning (only_props : bool) (s : simp_lemmas) : list (expr × list string) → tactic string
| [] := fail "forwards_reasoning failed"
| (e :: es) := do
    t ← infer_type e.1,
    t' ← try_core (s.dsimplify [] t), -- FIXME too expensive
    let changed := t'.is_some,
    let t := t'.get_or_else t,
    if t.is_pi then
      do hyps ← local_context,
         apps ← mk_apps e.1 hyps,
         apps ← apps.mmap (λ p, do h_pp ← pretty_print p.2, return (p.1, list.cons h_pp e.2)),
         attempt_forwards_reasoning (apps ++ es)
    else (do if only_props then guard_prop t else skip,
             guard_no_duplicate_hypothesis t,
             let n := "_".intercalate e.2.reverse,
             assertv n t e.1,
             term ← pretty_print e.1,
             -- TODO sometimes this reported tactic won't work, and we need to write instead
             -- `have n : t := by convert term`
             return ("have " ++ n ++ " := " ++ term)
             ) <|> attempt_forwards_reasoning es

/-- Attempt to `have` a lemma marked with the attribute @[forward], whose conclusion is not yet known and whose arguments can be filled in by hypotheses. -/
meta def forwards_library_reasoning : tactic string :=
do cs ← attribute.get_instances `forward,
   es ← cs.mmap (λ n, (do e ← mk_const n, let s := n.components.ilast.to_string, return (e, [s]))),
   s ← mk_simp_set ff [] [],
   attempt_forwards_reasoning ff s.1 es

/-- Attempt to `have` a result obtained by applying one hypothesis to others, as long as the conclusion is propositional, is not yet known, and has no further arguments. -/
meta def forwards_reasoning : tactic string :=
do hyps ← local_context,
   es ← hyps.mmap (λ e, (do s ← pretty_print e, return (e, [s]))),
   s ← mk_simp_set ff [] [],
   attempt_forwards_reasoning tt s.1 es

attribute [forward] congr_fun


import Hata.Conventions
import Mathlib.Data.Int.Basic
import Mathlib.Data.List.Basic
import Mathlib.Data.List.Zip

open List

inductive UniType where
  | Bool : UniType
  | Int : UniType
  | Float : UniType
  | Array : UniType -> UniType

mutual
  inductive BaseTerm : 𝒰 0 where
    | mkint : ℤ -> BaseTerm
    | mkbool : Bool -> BaseTerm

    | add : Term -> Term -> BaseTerm
    | mul : Term -> Term -> BaseTerm
    | ift : Term -> Term -> Term -> BaseTerm

  inductive Term where
    | var : String -> Term
    | base : BaseTerm -> Term
    | lambda : List String -> Term -> Term
    | app : Term -> List Term -> Term
    | err : String -> Term
end

open Term
open BaseTerm

instance : Coe BaseTerm Term where
  coe := base

infixl:80 " + " => add

example : Term
  := var "a" + var "a"

structure Env where
  vars : List (String × Term)

open Env

def getFirst : List (A × Term) -> Term
  | [] => err ("could not find variable")
  | (_ , t) :: _ => t

mutual
  unsafe def runTerm (Γ : Env) (t : Term) : Term :=
    match t with
    | (var v) => getFirst (Γ.vars.filter (λ (v₂ , _) ↦ v₂ == v))
    | (base b) => runBaseTerm Γ b
    | (lambda vs t) => (lambda vs t)
    | (app t args) => match runTerm Γ t with
                      | (lambda vs t) =>
                        let Γ' : Env :=
                          ⟨ (zip vs args) ++ Γ.vars ⟩
                        runTerm Γ' t
                      | _ => err ""
    | (err e) => err e

  unsafe def runBaseTerm (Γ : Env) (t : BaseTerm) : Term :=
    match t with
    | (mkint n) => mkint n
    | (mkbool b) => mkbool b
    | (ift c a1 a2) => match runTerm Γ c with
                       | (mkbool b) => ite b (runTerm Γ a1) (runTerm Γ a2)
                       | _ => err "could not eval condition to boolean"

    | (add a1 a2) => match (runTerm Γ a1, runTerm Γ a2) with
                       | (mkint a1, mkint a2) => mkint (a1 + a2)
                       | _ => err "add: could not eval operand(s) to int"

    | (mul a1 a2) => match (runTerm Γ a1, runTerm Γ a2) with
                       | (mkint a1, mkint a2) => mkint (a1 * a2)
                       | _ => err "mul: could not eval operand(s) to int"
end

def Γ₀ : Env := ⟨ [] ⟩

unsafe def n : Term := runTerm Γ₀ (mkint 1)

-- open Lean.Eval

def printBaseTerm (b : BaseTerm) :=
  match b with
  | (mkint i) => repr i
  | _ => "could not eval"

def printTerm (t : Term) :=
  match t with
  | (base b) => printBaseTerm b
  | _ => "could not eval"

instance : Repr (BaseTerm) where
  reprPrec := λ t x ↦ printBaseTerm t
  -- eval (mkint i) x _ := eval i

instance : Repr Term where
  reprPrec := λ t x ↦ printTerm t
  -- eval (base a) _ _ := eval a

unsafe def code := (runTerm Γ₀ (add (mkint 1) (mkint 2)))

#eval code

-- axiom a : terminates
-- termination_by runTerm Γ t => sorry
--                runBaseTerm Γ t => sorry


import tactic
import combinatorics.simple_graph.basic combinatorics.simple_graph.degree_sum data.set.basic
import graph_theory.to_mathlib
open function classical set finset

variables {V V' V'' : Type*}
variables {G H : simple_graph V} {G' : simple_graph V'} {G'' : simple_graph V''}

namespace simple_graph

def is_smaller (G : simple_graph V) (G' : simple_graph V') : Prop :=
∃ f : G →g G', injective f

infix ` ≼s `:50 := is_smaller

namespace is_smaller
@[refl] lemma refl : G ≼s G :=
⟨⟨id, λ x y, id⟩, injective_id⟩

@[trans] lemma trans : G ≼s G' → G' ≼s G'' → G ≼s G''
| ⟨f₁,h₁⟩ ⟨f₂,h₂⟩ := ⟨f₂.comp f₁, injective.comp h₂ h₁⟩

lemma iso_left : G ≃g G' → G' ≼s G'' → G ≼s G''
| φ ⟨ψ,h⟩ := ⟨ψ.comp φ, (φ.to_equiv.injective_comp ⇑ψ).mpr h⟩

lemma le_left : G ≤ H → H ≼s G' → G ≼s G'
| h₁ ⟨⟨f,h₂⟩,h₃⟩ := ⟨⟨f,λ _ _ h, h₂ (h₁ h)⟩,h₃⟩

lemma iso_right : G ≼s G' → G' ≃g G'' → G ≼s G''
| ⟨ψ,h⟩ φ := ⟨φ.to_hom.comp ψ, (equiv.comp_injective ψ φ.to_equiv).mpr h⟩
end is_smaller
end simple_graph