import predicate_logic
universe u

-- We introduce typed predicate logic.

namespace logic

open logic list tactic set

section typing
parameters {sort : Type u} [decidable_eq sort]
parameter {σ : @signature sort _}

local notation `uterm` := @uterm sort _ σ
local notation `tvariable` := @tvariable sort _ σ
local notation `nrary` := @nrary sort _ σ

include sort σ
def typing : uterm → sort
| (uterm.var ⟨s, _, _⟩) := s
| (uterm.app f _) := f.val.codomain

def type_check {n} (l : list sort) (v : fin n → uterm) : Prop :=
map typing (of_fn v) = l

inductive consistently_typed : uterm → Prop
| base {x : tvariable} : consistently_typed (uterm.var x)
| app {n : ℕ} (f : nary n) (v : fin n → uterm)
    (h₀ : ∀ x, consistently_typed (v x)) (h₁ : type_check f.val.domain v)
    : consistently_typed (uterm.app f v)

structure term :=
    (syntax : uterm)
    (check : consistently_typed syntax)

def type_matches (x : tvariable) (t : term) :=
    typing (uterm.var x) = typing (t.syntax)

-- typing (uterm.var x) = typing t₁.syntax →
theorem rewrite_consistent : ∀ (x : tvariable) (t₁ t₂ : term) (h : type_matches x t₁), consistently_typed (uterm.rewrite x t₁.syntax t₂.syntax) :=
begin
    intros x t₁ t₂ h,
    induction (t₁.syntax.rewrite x t₂.syntax),
        exact consistently_typed.base,
    simp at *,
    refine consistently_typed.app f v ih _,
    unfold type_check,
    induction c : (of_fn v),
        simp [c] at *,
        ext,
        admit,
    admit
end

def term.rewrite (x : tvariable) (t : term) (h : type_matches x t) : term → term :=
begin
    intro target,
    fsplit,
    exact t.syntax.rewrite x target.syntax,
    exact rewrite_consistent x t target h,
end

-- term typing
def ttyping : term → sort
| t := typing t.syntax

lemma term.rewrite_typing (x : tvariable) (t₁ : term) (h : type_matches x t₁)
                          (t₂ : term)
                          : ttyping (t₁.rewrite x h t₂) =  ttyping t₂ :=
sorry

-- term type_check
def ttc {n} (l : list sort) (v : fin n → term) : Prop :=
map ttyping (of_fn v) = l

structure name extends term :=
    (denotative : uterm.denotes syntax)

structure expression extends term :=
    (has_var : ¬ uterm.denotes syntax)

-- inductive atomic_formula
-- | relational {n : ℕ} (r : nrary n) (v : fin n → term)
--     (h : ttc r.val.sig v) : atomic_formula
-- | equation (t₁ t₂ : term) : atomic_formula
-- | true : atomic_formula
-- | false : atomic_formula

-- def atomic_formula.variables : atomic_formula → set tvariable
-- | (atomic_formula.relational r v h) :=
--     let  v₂ := term.syntax ∘ v
--     in uterm.list_variables (of_fn v₂)
-- | (atomic_formula.equation t₁ t₂) :=
--     uterm.variables t₁.syntax
--     ∪ uterm.variables t₂.syntax
-- | _ := ∅

-- def atomic_formula.rewrite (x : tvariable) (t : term) (h₀ : type_matches x t) : atomic_formula → atomic_formula
-- | (@atomic_formula.relational _ _ _ n r v h) :=
--     let v₂ := (term.rewrite x t h₀) ∘ v in
--     begin
--     refine atomic_formula.relational r v₂ _,
--     simp [ttc] at *,
--     cases c : of_fn v,
--         rw c at h,
--         simp at h,
--         replace h := eq.symm h,
--         have neq :=  r.val.sig_not_empty,
--         contradiction,
--     rw [←h],
--     have conc := t.rewrite_typing x h₀,
--     -- cases c₂ : of_fn v₂,
--     -- simp, library_search,
--     -- simp [v₂,  c, function.comp],
--     ext, constructor; intro hyp;
--     simp * at *,
--     rcases hyp with ⟨y, hyp₁, hyp₂⟩,
--         simp [v₂] at *,
--     -- suffices c :
--     --     map ttyping (of_fn v₂)
--     --     = map ttyping (of_fn v),
--     --     dsimp [ttc] at *,
--     --     rw c,
--     --     exact h,
--     -- dsimp [map],
--     -- ext, constructor; intro hyp;
--     -- simp * at *;
--     -- rcases hyp with ⟨x, hyp₁, hyp₂⟩,
--     --     existsi x,
--     --     simp [v₂, hyp₂] at *,
--     -- admit,
--     end
-- | (atomic_formula.equation t₁ t₂) :=
--     let t₁ := t.rewrite x h₀ t₁,
--         t₂ := t.rewrite x h₀ t₂
--     in atomic_formula.equation t₁ t₂
-- | φ := φ

-- inductive pre_formula
-- | atomic : atomic_formula → pre_formula
-- | for_all :  tvariable → pre_formula → pre_formula
-- | exist   : tvariable → pre_formula → pre_formula
-- | and : pre_formula → pre_formula → pre_formula
-- | or : pre_formula → pre_formula → pre_formula
-- | if_then : pre_formula → pre_formula → pre_formula

-- def pre_formula.is_atomic : pre_formula → Prop
-- | (logic.pre_formula.atomic _) := true
-- | _ := false

-- def pre_formula.is_molecular : pre_formula → Prop
-- | (logic.pre_formula.atomic _) := true
-- | (logic.pre_formula.and φ ψ) :=
--     pre_formula.is_molecular φ
--     ∧ pre_formula.is_molecular ψ
-- | (logic.pre_formula.or φ ψ) :=
--     pre_formula.is_molecular φ
--     ∧ pre_formula.is_molecular ψ
-- | (logic.pre_formula.if_then φ ψ) :=
--     pre_formula.is_molecular φ
--     ∧ pre_formula.is_molecular ψ
-- | _ := false

-- def pre_formula.free_variables : pre_formula → set tvariable
-- | (logic.pre_formula.atomic φ) := atomic_formula.variables φ
-- | (logic.pre_formula.for_all x φ) := pre_formula.free_variables φ - {x}
-- | (logic.pre_formula.exist x φ) := pre_formula.free_variables φ - {x}
-- | (logic.pre_formula.and φ ψ) :=
--     pre_formula.free_variables φ
--     ∪ pre_formula.free_variables ψ
-- | (logic.pre_formula.or φ ψ) :=
--     pre_formula.free_variables φ
--     ∪ pre_formula.free_variables ψ
-- | (logic.pre_formula.if_then φ ψ) :=
--     pre_formula.free_variables φ
--     ∪ pre_formula.free_variables ψ

-- def pre_formula.bound_variables : pre_formula → set tvariable
-- | (logic.pre_formula.atomic φ) := ∅
-- | (logic.pre_formula.for_all x φ) := pre_formula.bound_variables φ ∪ {x}
-- | (logic.pre_formula.exist x φ) := pre_formula.bound_variables φ ∪ {x}
-- | (logic.pre_formula.and φ ψ) :=
--     pre_formula.bound_variables φ
--     ∩ pre_formula.bound_variables ψ
-- | (logic.pre_formula.or φ ψ) :=
--     pre_formula.bound_variables φ
--     ∩ pre_formula.bound_variables ψ
-- | (logic.pre_formula.if_then φ ψ) :=
--     pre_formula.bound_variables φ
--     ∩ pre_formula.bound_variables ψ

-- def pre_formula.rewrite (x : tvariable) (t : uterm) : pre_formula → pre_formula
-- | (logic.pre_formula.atomic a) := _
-- | (logic.pre_formula.for_all a a_1) := _
-- | (logic.pre_formula.exist a a_1) := _
-- | (logic.pre_formula.and a a_1) := _
-- | (logic.pre_formula.or a a_1) := _
-- | (logic.pre_formula.if_then a a_1) := _

-- inductive well_formed : pre_formula → Prop
-- | atomic (φ : atomic_formula) : well_formed (pre_formula.atomic φ)
-- | for_all (x : tvariable) (φ : pre_formula)
--           (h₁ : well_formed φ) (h₂ : x ∈ pre_formula.free_variables φ)
--           : well_formed (pre_formula.for_all x φ)
-- | exist   (x : tvariable) (φ : pre_formula)
--           (h₁ : well_formed φ) (h₂ : x ∈ pre_formula.free_variables φ)
--           : well_formed (pre_formula.exist x φ)
-- | and (φ ψ : pre_formula)
--       (h₁ : well_formed φ)
--       (h₂ : well_formed ψ)
--       : well_formed (pre_formula.and φ ψ)
-- | or (φ ψ : pre_formula)
--      (h₁ : well_formed φ)
--      (h₂ : well_formed ψ)
--      : well_formed (pre_formula.or φ ψ)
-- | if_then (φ ψ : pre_formula)
--           (h₁ : well_formed φ)
--           (h₂ : well_formed ψ)
--           : well_formed (pre_formula.if_then φ ψ)

-- structure wff :=
--     (formula : pre_formula)
--     (well_formed : well_formed formula)

-- def wff.and : wff → wff → wff
-- | ⟨φ, h₁⟩ ⟨ψ, h₂⟩ := ⟨pre_formula.and φ ψ,
--                       well_formed.and φ ψ h₁ h₂⟩

-- def wff.or : wff → wff → wff
-- | ⟨φ, h₁⟩ ⟨ψ, h₂⟩ := ⟨pre_formula.or φ ψ,
--                       well_formed.or φ ψ h₁ h₂⟩

-- def wff.if_then : wff → wff → wff
-- | ⟨φ, h₁⟩ ⟨ψ, h₂⟩ := ⟨pre_formula.if_then φ ψ,
--                       well_formed.if_then φ ψ h₁ h₂⟩
-- def wff.true : wff :=
-- { formula := pre_formula.atomic atomic_formula.true,
--   well_formed := well_formed.atomic _
-- }

-- instance wff.has_exp : has_exp wff := ⟨wff.if_then⟩

-- def assertive (φ : pre_formula) := pre_formula.free_variables φ = ∅
-- def conotative (φ : pre_formula) := ¬ assertive φ

-- structure sentence extends wff :=
--     (assertive : assertive formula)

-- structure predicate extends wff :=
--     (conotative : conotative formula)

-- -- theorem finite_num_var : ∀ φ : pre_formula, finite (pre_formula.free_variables φ) :=
-- -- begin
-- --     intros φ,
-- --     repeat {induction φ},
-- --     -- repeat {fsplit},
-- --     -- unfold multiset,
-- --     -- work_on_goal 2 { intros x,
-- --     -- cases x,
-- --     -- simp at * },
-- -- end

-- inductive wff.entails : set wff → wff → Prop
-- | reflexive (Γ : set wff) (φ : wff)(h : φ ∈ Γ) : wff.entails Γ φ
-- | transitivity (Γ Δ : set wff) (φ : wff)
--                (h₁ : ∀ ψ ∈ Δ, wff.entails Γ ψ)
--                (h₂ : wff.entails Δ φ) :  wff.entails Γ φ
-- | and_intro (φ ψ : wff) (Γ : set wff)
--             (h₁ : wff.entails Γ φ)
--             (h₂ : wff.entails Γ ψ)
--              : wff.entails Γ (wff.and φ ψ)
-- | and_elim_left (φ ψ : wff) (Γ : set wff)
--             (h : wff.entails Γ (wff.and φ ψ))
--              : wff.entails Γ φ
-- | and_elim_right (φ ψ : wff) (Γ : set wff)
--             (h : wff.entails Γ (wff.and φ ψ))
--              : wff.entails Γ ψ
-- | or_intro_left
--             (φ ψ : wff) (Γ : set wff)
--             (h : wff.entails Γ φ)
--              : wff.entails Γ (wff.or φ ψ)
-- | or_intro_right
--             (φ ψ : wff) (Γ : set wff)
--             (h : wff.entails Γ ψ)
--              : wff.entails Γ (wff.or φ ψ)
-- | or_elim
--             (φ ψ δ : wff) (Γ : set wff)
--             (h₁ : wff.entails Γ (wff.or φ ψ))
--             (h₂ : wff.entails (Γ ∪ {φ}) δ)
--             (h₃ : wff.entails (Γ ∪ {ψ}) δ)
--              : wff.entails Γ δ
-- | modus_ponens
--             (φ ψ : wff) (Γ : set wff)
--             (h₁ : wff.entails Γ (φ ⇒ ψ))
--             (h₂ : wff.entails Γ φ)
--              : wff.entails Γ ψ
-- | intro
--             (φ ψ : wff) (Γ : set wff)
--             (h : wff.entails (Γ ∪ {φ}) ψ)
--              : wff.entails Γ (φ ⇒ ψ)
-- | true_intro
--             (Γ : set wff)
--              : wff.entails Γ wff.true
-- | true_intro
--             (Γ : set wff) (φ : wff)
--             (x : tvariable)
--             (free : x ∈ pre_formula.free_variables φ.formula)
--             (h : ∀ t : term wff.entails (Γ ∪ {φ}) ψ)
--              : wff.entails Γ wff.true

-- let l := of_fn v in
-- map typing l = f.val.domain
-- ∧ ∀ x ∈ l, consistently_typed x

-- begin
--     cases h : f.val.domain, exact true,
--     cases hyp : n with n₀, exact true,
--     have wfr : n₀ < n, -- for proving well-founded recursion
--         rw hyp,
--         exact nat.lt_succ_self n₀,
--     have c := nat.zero_lt_succ n₀,
--     have z : fin (nat.succ n₀) := ⟨0, c⟩,
--     refine typing _ = [hd] ∧ consistently_typed _,
--         rw hyp at v, exact (v z),
--     right, work_on_goal 2 {exact n₀},
--     constructor,
--     work_on_goal 1{
--         constructor,
--         exact f.val.name ++ "tail",
--         exact tl,
--         exact f.val.codomain,
--     },
--         constructor,
--         have c₂ := (σ.head_project f.val f.property.left),
--         simp [tail_symbol] at c₂,
--         rwa h at c₂,
--         simp [arity],
--         replace c₂ : tl = tail f.val.domain,
--             simp [h],
--         simp [c₂],
--         replace c₂ : length f.val.domain = n := f.property.right,
--         rw [c₂, hyp],
--         refl,
--     rintros ⟨x, hx⟩,
--     refine v ⟨x+1, _⟩, rw hyp,
--     exact nat.lt_succ_iff.mpr hx
-- end
-- using_well_founded { rel_tac := _,
-- dec_tac := `[rw hyp, exact nat.lt_succ_self n₀] }
end typing
end logic


import .basic

universes u
variables {V : Type u}

section list

lemma list.cons_nth_le_succ
  {α : Type*} {hd : α} (tl : list α)
  (n : ℕ) (hn : n + 1 < (tl.cons hd).length)
  (h_auto : n < tl.length := by tidy)
  :
(tl.cons hd).nth_le (n + 1) hn = tl.nth_le n h_auto := rfl

lemma list.cons_nth_le_succ'
  {α : Type*} (l : list α)
  (n : ℕ) (hn : n + 1 < l.length)
  (h_auto : n < l.tail.length)
  :
l.nth_le (n + 1) hn = l.tail.nth_le n h_auto :=
by { cases l, { cases hn }, simp; refl }

@[simp] lemma list.nth_le_succ_tail
  {α : Type*} (l : list α)
  (n : ℕ) (hn : n < l.tail.length)
  (h_auto : n + 1 < l.length)
  -- (h_auto : n + 1 < l.length := by { simp at hn, omega })
   :
l.nth_le (n + 1) h_auto = l.tail.nth_le n hn :=
by { cases l, tidy }

@[simp] lemma list.tail_nth_le_zero
  {α : Type*} (l : list α) [inhabited α]
  (h_auto : 0 < l.length) :
list.nth_le l 0 h_auto = l.head :=
by { cases l, { cases h_auto }, tidy, }

end list

namespace simple_graph
variables (G : simple_graph V)

/-- Morally, a path is an alternating list of vertices and edges,
  with incidences between adjacent objects -/
@[ext] structure path :=
(head : V)
(tail : list V)
(edges : list G.E)
(length_eq : edges.length = tail.length)
(adj : ∀ (n : ℕ) (hn : n < edges.length),
  let u := (list.cons head tail).nth_le n (by { simp; omega }) in
  let v := (list.cons head tail).nth_le (n + 1) (by { simp, cc }) in
  u ≠ v ∧ u ∈ edges.nth_le n hn ∧ v ∈ edges.nth_le n hn)

namespace path
variables {G}
variables (p : G.path)

section classical
open_locale classical
/-- The last vertex in p. -/
noncomputable def last : V := if h : p.tail = list.nil then p.head else p.tail.last h

end classical

/-- The ordered list of all vertices in p, starting at p.head and ending at p.sink. -/
def vertices : list V := p.head :: p.tail

/-- The number of edges in p. -/
def length : ℕ := p.tail.length
-- should probably make sure this doesn't become a problem if we run into infinite graphs?

@[simp] lemma tail_length_eq : p.tail.length = p.length := rfl
@[simp] lemma edges_length_eq : p.edges.length = p.length :=  by simp [p.length_eq]
@[simp] lemma vertices_tail : p.vertices.tail = p.tail := by simp [path.vertices]
@[simp] lemma vertices_length : p.vertices.length = p.length + 1 := by simp [path.vertices]

#check list.nth_eq_some
lemma head_ne_tail_head [inhabited V] (h : p.tail ≠ list.nil) : p.head ≠ p.tail.head :=
begin
  rcases p.adj 0 _ with ⟨hp, _⟩, dsimp at hp, convert hp,
  cases hp1 : p.tail,
  { contradiction },
  { simp [hp1] },
  { revert h, rw ← list.length_pos_iff_ne_nil, simp },
end

-- begin

-- end

-- variables {s t : V}

variables {p}
/-- p.edge_mem e holds if e is an edge along path p. -/
def edge_mem (e : G.E) (p : G.path) : Prop := e ∈ p.edges
-- this instance doesn't fire and I don't know why
instance has_mem_edge : has_mem G.E G.path :=
{ mem := edge_mem }

/-- p.vertex_mem v holds if v is a vertex along path p. -/
def vertex_mem (v : V) (p : G.path) : Prop := v ∈ p.vertices
instance has_mem_vertices : has_mem V G.path :=
{ mem := vertex_mem }
variables (p)

/-- The empty path based at vertex v. -/
@[simps]
def empty (G : simple_graph V) (v : V) : G.path :=
{ head := v,
  tail := list.nil,
  edges := list.nil,
  length_eq := rfl,
  adj := by rintros _ ⟨_⟩ }

instance [inhabited V] : inhabited G.path := { default := empty G (arbitrary V) }

@[simp]
lemma empty_length (v : V) : (empty G v).length = 0 := by refl

lemma edge_mem_empty {v : V} (e : G.E) : ¬ (empty G v).edge_mem e :=
by simp [empty, edge_mem]

lemma vertex_mem_empty {u v : V} : u ∈ (empty G v) ↔ u = v :=
by { unfold has_mem.mem vertex_mem, simp [empty, vertices], apply or_false }

/-- p.cons e hp hs is the path extending `p` by edge `e`. -/
def cons {s : V} (e : G.E) (hp : p.head ∈ e) (hs : s ∈ e) (hsp : s ≠ p.head) : G.path :=
{ head := s,
  tail := p.vertices,
  edges := list.cons e p.edges,
  length_eq := by { simp [vertices] },
  adj := begin
    intros n hn _ _,
    cases n, { simp, tauto },
    simp; apply p.adj,
  end }

@[simp] lemma edge_mem_cons {s : V} (hd e : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).edge_mem e ↔ e = hd ∨ p.edge_mem e :=
by simp [path.cons, path.vertices, edge_mem]

@[simp] lemma vertex_mem_cons {v s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  v ∈ (p.cons hd hp hs hsp) ↔ v = s ∨ v ∈ p :=
by refl

@[simp] lemma cons_length {s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).length = p.length + 1 :=
by { unfold cons length, simp [vertices] }

@[simp] lemma cons_vertices {s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).vertices = list.cons s p.vertices :=
by { dsimp [vertices, cons], simp }

lemma edges_eq_nil_iff : p.edges = list.nil ↔ p.tail = list.nil :=
by rw [← list.length_eq_zero, p.length_eq, list.length_eq_zero]

lemma length_eq_zero_iff_eq_empty : p.length = 0 ↔ p = empty G p.head :=
begin
  erw list.length_eq_zero,
  split; intro h, swap, rw h, simp [empty],
  ext, work_on_goal 2 {rw ← edges_eq_nil_iff at h},
  any_goals {simp [empty, h]},
end

lemma cases_on' [inhabited V] :
  (∃ v, p = empty G v) ∨
  ∃ (tl : G.path) v e (hs : tl.head ∈ e) (hv : v ∈ e) (hvp : v ≠ tl.head), p = tl.cons e hs hv hvp :=
begin
  cases hp : p.edges with hd tl,
  { left, use p.head, ext, { simp [empty] },
    { suffices : p.tail = list.nil, { simp [empty, this] },
      rwa edges_eq_nil_iff at hp },
    simp [hp, empty] },
  have hp_nil : ¬ p.edges = list.nil, { simp [hp] },
  rw edges_eq_nil_iff at hp_nil,

  rcases p.adj 0 _ with ⟨hvs, hv, hs⟩, simp only [list.nth_le, zero_add] at hs,
  repeat { rw list.nth_le_zero at * },
  set q : G.path := { head := p.tail.head,
    tail := list.tail p.tail,
    edges := list.tail p.edges,
    length_eq := by simp [p.length_eq],
    adj := _},
  swap, { intros, have := p.adj (n + 1) (by { simp only [list.length_tail] at hn, exact nat.add_lt_of_lt_sub_right hn, }),
    simp only [list.nth_le] at this ⊢,
    cases this with huv this,
    cases hp_tail : p.tail with p_hd p_tl, { contradiction },
    dsimp [u,v], simp [hp_tail],   split,
    { contrapose! huv, symmetry, convert huv using 1; simp [hp_tail, huv]; refl },
    -- simp [hp_tail, this],
    -- rw list.tail_nth_le,
    convert this using 2,
    any_goals { simp [hp_tail]; refl },
    -- { rw list.cons_head_tail hp_nil, refl },
    iterate 2 { rwa list.cons_nth_le_succ' },
    },
  right, use [q, p.head, hd],
  simp only [hp, list.head] at hs hv, swap, { simp [hp] },
  dsimp, use [hs, hv], split,
  ext,
  { simp [path.cons] },
  { dsimp [q, path.cons, path.vertices], rwa list.cons_head_tail, },
  { dsimp [q, path.cons], simp [hp] },
  revert hvs, simp,
end

@[elab_as_eliminator]
lemma induction_on [inhabited V]
  (P : G.path → Prop)
  (P_empty : ∀ v, P $ empty G v)
  (P_inductive : ∀ tl hd hs {v} (hv : v ∈ hd) (hsv), P tl → P (tl.cons hd hs hv hsv)) :
P p :=
begin
  suffices : ∀ k (q : G.path), q.length = k → P q, { apply this p.length, refl },
  intro k, induction k with k hk, { intros, convert P_empty _, rwa ← length_eq_zero_iff_eq_empty },
  intro q, rcases q.cases_on' with ⟨_,rfl⟩|⟨_,_,_,_,_,_,rfl⟩, { intro, apply P_empty },
  intro, apply P_inductive, apply hk, simp at a, omega,
end

lemma consecutive_vertex_ne [inhabited V] {n} (h : n < p.length) :
p.vertices.nth_le n (by { simp, linarith }) ≠
p.vertices.nth_le (n+1) (by { simp, linarith }) :=
begin
  revert n,
  convert p.induction_on (λ q, ∀ n (h : n < q.length), q.vertices.nth_le n _ ≠ q.vertices.nth_le (n+1) _) _ _,
  { simp }, iterate 2 { simp, omega },
  { rintros _ _ ⟨⟩ },
  clear p, intros _ _ _ _ _ _ h n hn,
  cases n, { simpa },
  convert h _ _,
  simp at hn, omega,
end

lemma consecutive_edge_ne [inhabited V] {n} (h : n < p.length) :
p.edges.nth_le n (by { simp, linarith }) ≠
p.edges.nth_le (n+1) (by { simp, sorry, }) :=
begin
  sorry,
end

@[ext] lemma eq_of_vertices_eq [inhabited V] (q : G.path) :  p = q ↔ p.vertices = q.vertices :=
{ mp := by tidy,
  mpr := begin
    intro h, have h_tail : p.tail = q.tail,
    { dsimp [vertices] at h, simp only [] at h, tauto },
    have h_length : p.length = q.length := by rw [← tail_length_eq, h_tail, tail_length_eq],
    ext, { tidy }, { simp [h_tail] },
    by_cases hn : n < p.length; have hnq := by { rw h_length at hn, exact hn },
    swap, { simp [hn, hnq, list.nth_eq_some] },
    suffices : p.edges.nth_le n _ = q.edges.nth_le n _,
    { simp [hn, hnq, list.nth_eq_some]; refine eq.congr this rfl },
    rw edge_eq_iff,
    set u := p.vertices.nth_le n (by { simp [path.vertices], linarith }),
    set v := p.vertices.nth_le (n+1) (by { simp [path.vertices], linarith }),
    use [u, v],
    split, symmetry, apply consecutive_vertex_ne,
    rcases p.adj n _ with ⟨_, hpu, hpv⟩,
    rcases q.adj n _ with ⟨_, hqu, hqv⟩,
    split, { exact hpu },
    split, { convert hqu, dsimp [u], simp_rw h, refl },
    split, { exact hpv },
    { convert hqv, dsimp [v], simp_rw h, refl },
  end }

/-- p.is_cycle if p starts and ends in the same place. -/
def is_cycle : Prop := p.head = p.last

/-- p.is_trail if p has no repeated edges. -/
def is_trail : Prop := list.nodup p.edges

/-- p.is_tour if p has no repeated vertices. -/
def is_tour : Prop := list.nodup p.vertices
-- maybe prove that `is_tour → is_Eulerian`

/-- p.is_Eulerian if p hits each edge exactly once. -/
def is_Eulerian : Prop := p.is_trail ∧ ∀ e : G.E, p.edge_mem e

/-- p.is_maximal if the length of p is greater than or equal to the length of every other path. -/
def is_maximal : Prop := p.is_tour ∧ ∀ (q : path G), q.length ≤ p.length --should probably figure out some fintype stuff here lol

structure simple_cycle : Prop :=
(is_cycle : p.is_cycle)
(is_tour : p.is_tour)

/-example {V : Type u}
  {G : simple_graph V}
  (p : G.path)
  [inhabited V]
  (h : p.vertices.nodup)
  (tl : G.path)
  (hd : G.E)
  (hs : tl.head ∈ hd)
  {v : V}
  (hv : v ∈ hd)
  (hsv : v ≠ tl.head)
  (a : list.pairwise ne tl.edges)
  (f : G.E)
  (hf : f ∈ tl.edges) :
  hd ≠ f :=
begin
  contrapose! h,
  subst hd,
end-/

-- should have this lemma
lemma edge_path_mem_vertices {p : G.path} {e : G.E} {u : V} (h1 : e ∈ p.edges) : u ∈ e → (u ∈ p.vertices) :=
begin
  --apply p.adj,
  sorry,
end

lemma tour_is_trail [inhabited V] : p.is_tour → p.is_trail :=
begin
  intro h,
  unfold is_trail,
  unfold is_tour at h,
  unfold list.nodup,
  /-apply p.induction_on, -- this seems to be where it all goes wrong
  { intro, rw list.pairwise_iff, simp },
  intros,
  intros, rw list.pairwise_iff, right,
  use [hd, tl.edges],
  split, swap, { tauto },
  intros f hf,
  contrapose! hf, subst hf,
  suffices : v ∉ tl.vertices, contrapose! this,
  apply edge_path_mem_vertices this hv,-/
  -- i think this may be impossible to prove at this point and i don't know where it all went wrong

    -- something like `apply h`,
  sorry
end

end path

end simple_graph


-- We create a verified conversion from SSA minus Regions (ie, a sequence
-- of let bindings) into an expression tree. We prove that this
-- conversion preserves program semantics.
import Mathlib.Data.Set.Basic
import Mathlib.Data.Set.Function
import Mathlib.Data.Set.Image
import Mathlib.Tactic.Linarith
import Aesop

def Sigma.mapRight {T: Type} {f f': T → Type} (map: ∀ {t: T}, f t → f' t):
  (Σ (a: T), f a) → Σ (a: T), f' a :=
  fun ⟨a, fa⟩ => ⟨a, map fa⟩

namespace ToTree

-- Kinds of values
inductive Kind where
| int
| unit
| pair : Kind → Kind → Kind
deriving DecidableEq

-- Kinds of expressions
inductive ExprKind
| O -- single op
| Os -- sequence of ops
abbrev Var := String

-- Well typed, simply typed kinds of ops. eg. 'add' takes two 'ints' and returns an 'int'
 inductive OpKind : Kind → Kind → Type
| add: OpKind (.pair .int .int) .int
| const : OpKind .unit .int
| sub: OpKind (.pair .int .int) .int
| negate: OpKind .int .int

inductive Expr : ExprKind → Kind → Type where
| assign (ret : Var) (kind: OpKind i o) (arg: Var) : Expr .O o -- ret = kind (arg)
| pair (ret : Var) (arg1: Var) (k1: Kind) (arg2 : Var) (k2: Kind) : Expr .O (Kind.pair k1 k2) -- ret = (arg1, arg2)
| ops: Expr .O kop → Expr .Os ks → Expr .Os ks -- op ;; ops.
| single: Expr .O kop → Expr .Os kop

-- the return variable of the expression. ie, what is the
-- name of the final value that this expression computes.
abbrev Expr.retVar : Expr ek k → Var
| .assign (ret := ret) .. => ret
| .pair (ret := ret)  .. => ret
| .ops _ o2 => o2.retVar
| .single o => o.retVar

abbrev Op := Expr .O
abbrev Ops := Expr .Os

abbrev Op.retKind: Op k → Kind := fun _ => k

-- builder helpers
@[match_pattern]
abbrev Op.assign (ret : Var) (kind : OpKind i o) (arg : Var) : Op o :=
  Expr.assign ret kind arg

@[match_pattern]
abbrev Op.pair (ret : Var) (arg1 : Var) (k1: Kind) (arg2: Var) (k2: Kind) : Op (Kind.pair k1 k2) :=
  Expr.pair ret arg1 k1 arg2 k2

abbrev Op.ret : Expr .O k → String
| .pair (ret := ret) .. => ret
| .assign (ret := ret) .. => ret

/-
TODO: make a section and use `variable` for reuse
-/

-- A TypingContext that tracks which variables have been defined.
def TypingContext := String → Option Kind

-- empty def context
def TypingContext.bottom : TypingContext := fun _ => .none

-- bind the name 'name' of kind 'kind' to the def context 'ctx.
def TypingContext.bind (bindname : String) (bindkind: Kind) (ctx: TypingContext): TypingContext :=
  fun name => if name = bindname then bindkind else ctx name

notation ctx "[" bindname " ↦ " bindk  "]" => TypingContext.bind bindname bindk ctx

/-
Actually, I feel like I am stupid. We don't usually write the typing judgement
as 'returning' a context, we write it as 'having' a context. So, I think I need
to change the definition of ExprWellTyped to be

Key insight: Do not phrase it as a function that returns a context, phrase it
as a relation between a context and an expression. This forces us to be "productive"
in the case where we concatenate two expressions. This means that we get stronger
induction hypotheses. Furthermore, this is morally the correct way to think about the
situation. We are not "returning" a context, we "have" a context to define well typedness.
This solves the entire collection of problems around showing that we return a context
deterministically and so on.
-/
-- inductive propsition which asserts when an expression is well formed.
@[aesop constructors safe, aesop cases safe]
inductive ExprWellTyped : {ek: ExprKind} → {k: Kind} → TypingContext → Expr ek k →  Type where
| assign
    {ret arg : Var}
    {ctx : TypingContext}
    {kind: OpKind i o}
    (ARG : ctx arg = .some i)
    (RET: ctx ret = .none) :
    ExprWellTyped ctx (Op.assign ret kind arg)
| pair
  {ctx : TypingContext}
  {ret arg1 arg2 : Var}
  {k1 k2 : Kind}
  (ARG1 : ctx arg1 = .some k1)
  (ARG2 : ctx arg2 = .some k2)
  (RET: ctx ret = .none) :
  ExprWellTyped ctx (Op.pair ret arg1 k1 arg2 k2)
| ops
  {ctxbegin ctxmid : TypingContext}
  (op1: Op k)
  (op2: Ops ks)
  (WT1: ExprWellTyped ctxbegin op1)
  (CTXMID: (ctxbegin.bind op1.retVar k) = ctxmid)
  (WT2: ExprWellTyped ctxmid op2) :
  ExprWellTyped ctxbegin (Expr.ops op1 op2)
| single
  {ctx : TypingContext}
  (op: Op k)
  (WT: ExprWellTyped ctx op) :
  ExprWellTyped ctx (Expr.single op)

notation "wt[" ctx " ⊢ " e "]" => ExprWellTyped ctx e

-- computational version of 'ExpreWellFormed' for reflection.
def ExprWellTyped.compute : Expr ek k → TypingContext → Bool
| (.assign (i := i) (o := o) ret _kind arg), ctx =>
    if ctx ret ≠ .none
    then false
    else if ctx arg ≠ i
    then false
    else true
| (.pair ret arg1 k1 arg2 k2), ctx =>
    if ctx ret ≠ .none then false
    else if ctx arg1 ≠ k1 then false
    else if ctx arg2 ≠ k2 then false
    else true
| (.ops op1 op2 (kop := kop)), ctx =>
    match ExprWellTyped.compute op1 ctx with
    | false => false
    | true => ExprWellTyped.compute op2 (ctx.bind op1.retVar kop)
| .single op, ctx => ExprWellTyped.compute op ctx

-- completeness: if the inducitve propositoin holds, then the decision
-- procedure says yes.
theorem ExprWellTyped.prop_implies_compute:
  ∀ {ctx } {expr : Expr ek k},
  ExprWellTyped ctx expr -> @ExprWellTyped.compute ek k expr ctx := by {
  intros ctx expr;
  revert ctx;
  induction expr;
  case assign ret kind arg => {
    intros ctx WELLFORMED;
    cases WELLFORMED;
    case assign RET ARG => {
      simp[compute]; aesop;
    }
  }
  case pair ret arg1 arg2 => {
    intros ctx WELLFORMED;
    cases WELLFORMED;
    case pair RET ARG1 ARG2 => {
      simp[compute]; aesop;
    }
  }
  case ops kop kops op1 ops IH_OP IH_OPS => {
    intros ctx WELLFORMED;
    cases WELLFORMED;
    case ops WT_OP MID WT_OPS => {
      subst MID;
      simp[compute];
      simp[IH_OP WT_OP];
      simp[IH_OPS WT_OPS];
    }
  }
  case single op IH => {
    intros ctx WELLFORMED;
    simp[compute];
    cases WELLFORMED;
    case single WT => {
      simp[IH WT];
    }
  }
}

instance : Subsingleton (@ExprWellTyped ek k ctx op) :=
 ⟨fun wf1 wf2 => by {
    induction wf1;
    case assign i o ret arg ctx kind ARG RET => {
      cases wf2; simp[proofIrrel];
    };
    case pair ret arg1 arg2 k1 k2 ARG1 ARG2 RET => {
      cases wf2; simp[proofIrrel];
    };
    case ops op' ops' ctxbegin ctxend ctxmid WT_OP MID WT_OPS IH_OP IH_OPS => {
      subst MID;
      cases wf2;
      case ops  WT_OP' MID' WT_OPS' => {
        subst MID';
        -- Need a theorem that ExprWellTyped returns a deterministic "ctx'"
        have IH_OP' := IH_OP WT_OP';
        have IH_OPS' := IH_OPS WT_OPS';
        simp[proofIrrel];
        constructor <;> assumption;
      }
    }
    case single op WT IH => {
      cases wf2;
      case single WT' => {
        have IH := IH WT';
        simp[proofIrrel];
        exact IH;
      }
    }
  }
⟩

-- -- (compute = true) => (stuff holds)
theorem ExprWellTyped.compute_implies_prop:
  ∀ {ctx : TypingContext} {expr : Expr ek k},
  ExprWellTyped.compute expr ctx ->
  ExprWellTyped ctx expr := by {
  intros ctx expr;
  revert ctx;
  induction expr;
  case assign i o ret kind arg  => {
    intros ctx COMPUTE;
    simp[compute] at COMPUTE;
    cases RET:(ctx ret) <;> simp[RET] at COMPUTE; case none => {
      cases ARG:(ctx arg) <;> simp[ARG] at COMPUTE; case some argk => {
        constructor <;> try assumption;
        case ARG => {
            by_cases VAL:(argk = i) <;> simp[VAL] at COMPUTE;
            aesop
        }
      }
    }
  }
  case pair ret arg1 k1 arg2 k2 => {
    intros ctx COMPUTE;
    simp[compute] at COMPUTE;
    cases RET:(ctx ret) <;> simp[RET] at COMPUTE; case none => {
      cases ARG1:(ctx arg1) <;> simp[ARG1] at COMPUTE; case some arg1k => {
        cases ARG2:(ctx arg2) <;> simp[ARG2] at COMPUTE; case some arg2k => {
          by_cases VAL1:(arg1k = k1) <;> simp[VAL1] at COMPUTE;
          by_cases VAL2:(arg2k = k2) <;> simp[VAL2] at COMPUTE;
          constructor <;> try aesop;
        }
      }
    }
  }
  case ops kop ks o1 o2 IH1 IH2 => {
    intros ctx  COMPUTE;
    simp[compute] at COMPUTE;
    cases CTXO1:(compute o1 ctx) <;> simp[CTXO1] at COMPUTE; case true => {
      cases CTXO2:(compute o2 (ctx[Expr.retVar o1 ↦ kop])) <;> simp[CTXO2] at COMPUTE; case  true => {
        constructor <;> aesop
      }
    }
  }
  case single op IH => {
    intros ctx COMPUTE;
    simp[compute] at COMPUTE;
    cases CTXOP:(compute op ctx) <;> simp[CTXOP] at COMPUTE; case true => {
      constructor; aesop
    }
  }
}

/-
TODO: make a section and use `variable` for reuse
-/

-- context necessary for evaluating expressions.
def EvalContext (kindMotive: Kind → Type) : Type
  := String → Option ((kind: Kind) × (kindMotive kind))

def EvalContext! (kindMotive: Kind → Type) : Type
  := String → (kind: Kind) → (kindMotive kind)

-- empty evaluation context.
def EvalContext.bottom (kindMotive: Kind → Type) : EvalContext kindMotive := fun _  => .none

-- add a binding into the evaluation context.
def EvalContext.bind {kindMotive: Kind → Type}
  (bindname : String) (bindk: Kind) (bindv: kindMotive bindk)
  (ctx: EvalContext kindMotive) : EvalContext kindMotive :=
  fun name => if (name = bindname) then .some ⟨bindk, bindv⟩ else ctx name

def EvalContext!.bind {kindMotive: Kind → Type}
  (bindname : String) (bindk: Kind) (bindv: kindMotive bindk)
  (ctx: EvalContext! kindMotive) : EvalContext! kindMotive :=
  fun name kind => if (name = bindname) then if H : (kind = bindk)  then H ▸ bindv else ctx name kind else ctx name kind

notation ctx "[" bindname ":" bindk " ↦ "  bindv  "]" => EvalContext.bind bindname bindk bindv ctx

-- lookup a binding by both name and kind.
@[simp]
def EvalContext.lookupByKind {kindMotive: Kind → Type} (ctx: EvalContext kindMotive)
  (name : String) (needlekind: Kind) : Option (kindMotive needlekind) :=
  match ctx name with
  | .none => .none
  | .some ⟨k, kv⟩ =>
      if NEEDLE : needlekind = k
      then NEEDLE ▸ kv
      else .none

@[simp]
def EvalContext.lookupByKind! {kindMotive: Kind → Type} (ctx: EvalContext! kindMotive)
  (name : String) (needlekind: Kind) (default: (k: Kind) → kindMotive k) : Option (kindMotive needlekind) :=
    ctx name needlekind

notation ctx "[" name ":" bindk "]?" => EvalContext.lookupByKind ctx name bindk

-- Simplify `lookupByKind` when we have a syntactically
-- matching `lookup`result.
@[aesop destruct safe]
theorem EvalContext.lookupByKind_lookup_some_inv {kindMotive: Kind → Type} {ectx: EvalContext kindMotive}
  {k: Kind} {v: kindMotive k} {name: String}
  (LOOKUP: ectx.lookupByKind name k = .some v) :
  ectx name = some { fst := k, snd := v } := by {
    simp[EvalContext.lookupByKind, LOOKUP] at LOOKUP ⊢;
    aesop;
  }

-- Treat an eval context as a def context by ignoring the eval value.
@[coe, aesop safe]
def EvalContext.toTypingContext (ctx: EvalContext kindMotive): TypingContext :=
  fun name =>
    match ctx name with
    | .none => .none
    | .some ⟨k, _kv⟩ => k

-- coerce an eval context to a typing context.
instance : Coe (EvalContext kindMotive) TypingContext := ⟨EvalContext.toTypingContext⟩

-- If 'tctx' has a value at 'name', then so does 'ectx' at 'name' if
-- 'tctx' came from 'ectx'.
@[aesop safe]
def EvalContext.toTypingContext_preimage_some
  { kindMotive: Kind → Type} -- what each kind is compiled into.
  {ectx: EvalContext kindMotive}
  {tctx: TypingContext}
  (TCTX: EvalContext.toTypingContext ectx = tctx)
  {name : String}
  {kind : Kind}
  (LOOKUP: tctx name = .some kind) :
  { val : kindMotive kind // ectx name = .some ⟨kind, val⟩ } := by {
    simp[toTypingContext] at TCTX; aesop;
}

@[aesop safe]
def EvalContext.toTypingContext_lookupByKind_preimage_some
  { kindMotive: Kind → Type} -- what each kind is compiled into.
  {ectx: EvalContext kindMotive}
  {tctx: TypingContext}
  (TCTX: EvalContext.toTypingContext ectx = tctx)
  {name : String}
  {kind : Kind}
  (LOOKUP: tctx name = .some kind) :
  { val : kindMotive kind // ectx.lookupByKind name kind = .some val } := by {
    simp[toTypingContext] at TCTX; aesop;
}

@[aesop norm]
theorem EvalContext.toTypingContext_preimage_none
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  {ectx: EvalContext kindMotive}
  {tctx: TypingContext}
  (TCTX: EvalContext.toTypingContext ectx = tctx)
  {name : String}
  (LOOKUP: tctx name = .none) :
  ectx name = .none := by {
    simp[toTypingContext] at TCTX; aesop;
}

@[aesop norm]
theorem EvalContext.toTypingContext_preimage_none_inv
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  {ectx: EvalContext kindMotive}
  {tctx: TypingContext}
  (TCTX: EvalContext.toTypingContext ectx = tctx)
  {name : String}
  (LOOKUP: ectx name = .none) :
  tctx name = .none := by {
    simp[toTypingContext] at TCTX; aesop;

}

-- ((name, kind, val) :: ectx).toTypingContext = (name, kind) :: ectx.toTypingContext
-- Alternatively, 'toTypingContext' is a homomorphism of contexts.
@[aesop simp norm]
theorem EvalContext.toTypingContext_bind
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  {ectx: EvalContext kindMotive}
  {tctx: TypingContext}
  (TCTX: EvalContext.toTypingContext ectx = tctx)
  {kind : Kind}
  {val: kindMotive kind}
  {arg: String} :
  (EvalContext.bind arg kind val ectx).toTypingContext = TypingContext.bind arg kind tctx := by {
    funext key;
    simp[toTypingContext, TypingContext.bind, EvalContext.bind];
    -- | TODO: golf
    by_cases NAME:(key = arg) <;> simp[NAME]; aesop
}

@[aesop norm unfold 1000]
def Expr.eval? -- version of fold that returns option.
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  (ctx : EvalContext kindMotive): (e : Expr ek k) → Option (kindMotive k)
| .assign (i := i) (o := o) ret opkind arg =>
    match ctx.lookupByKind arg i with
    | .none => .none
    | .some argv =>
        match ctx ret with
        | .some _ => .none
        | .none => opFold opkind argv

| .pair ret arg1 k1 arg2 k2 =>
  match ctx.lookupByKind arg1 k1, ctx.lookupByKind arg2 k2 with
    | .some arg1v, .some arg2v =>
      match ctx ret with
      | .some _ => .none
      | .none => pairFold arg1v arg2v
    | _, _ => .none
| .ops o1 o2 (kop := kop)=>
  match o1.eval? opFold pairFold ctx with
  | .none => .none
  | .some v =>  o2.eval? opFold pairFold (ctx.bind o1.retVar kop v)
| .single o => o.eval? opFold pairFold ctx
notation "expr⟦⟧?[" opFold ", " pairFold " ; " ctx " ⊧ " "⟦" e "⟧" "]" => Expr.eval? opFold pairFold  ctx e

def Expr.eval!
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  (default: (k: Kind) → kindMotive k)
  (ctx : EvalContext! kindMotive): (e : Expr ek k) → kindMotive k
| .assign (i := i) (o := o) ret opkind arg =>
    let argv := ctx arg i
    opFold opkind argv
| .pair ret arg1 k1 arg2 k2 =>
    let arg1v := ctx arg1 k1;
    let arg2v :=  ctx arg2 k2;
    pairFold arg1v arg2v
| .ops o1 o2 (kop := kop) => o2.eval! opFold pairFold default (ctx.bind o1.retVar kop (o1.eval! opFold pairFold default ctx))
| .single o => o.eval! opFold pairFold default ctx

-- unfolding theorem for 'eval?' at ops
theorem Expr.eval?_ops
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  (ctx : EvalContext kindMotive)
  (o1: Expr .O k1)
  (o2: Expr .Os k2):
  Expr.eval? opFold pairFold ctx (Expr.ops o1 o2) =
  match Expr.eval? opFold pairFold ctx o1 with
  | .none => .none
  | .some v => Expr.eval? opFold pairFold (ctx.bind o1.retVar k1 v) o2 := by {
    simp[eval?]; aesop;
  }

-- 'eval?' will return a 'some' value
-- Note that here, we must ford TCTX, since to perform induction on 'wellformed',
-- we need the indexes of 'wellformed' to be variables.
-- set_option trace.aesop.steps true in
@[aesop safe 1000]
theorem Expr.eval?_succeeds_if_expr_wellformed
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  {opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o}
  {pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i')}
  {ectx : EvalContext kindMotive}
  (TCTX: ↑ectx = tctx)
  {e : Expr ek k}
  (WT: ExprWellTyped tctx e) :
  { out // (e.eval? opFold pairFold ectx = .some out) } := by {
    revert ectx;
    induction WT;
    case assign i o ret arg ectx_tctx name ARG RET => {

      intros ectx TCTX;

      -- aesop
      -- TODO: how to have aesop automatically do this?
      have ⟨arg_val, ARG_VAL⟩ := EvalContext.toTypingContext_preimage_some TCTX ARG;
      have RET_VAL := EvalContext.toTypingContext_preimage_none TCTX RET;
      aesop  (options := { maxRuleApplicationDepth := 0, maxRuleApplications := 0, traceScript := true});
    }

    case pair tctx  ret arg1 arg2 k1 k2 ARG1 ARG2 RET  => {
      intros ectx TCTX;
      -- TODO: how to aesopify?
      have ⟨arg1_val, ARG1_VAL⟩ := EvalContext.toTypingContext_preimage_some TCTX ARG1;
      have ⟨arg2_val, ARG2_VAL⟩ := EvalContext.toTypingContext_preimage_some TCTX ARG2;
      have RET_VAL := EvalContext.toTypingContext_preimage_none TCTX RET;

      aesop  (options := { maxRuleApplicationDepth := 0, maxRuleApplications := 0, traceScript := true});
      -- apply EvalContext.toTypingContext_bind TCTX;
    }
    case ops op ops ctxbegin ctxend ctxmid _WT_OP MID _WT_OPS IH1 IH2 => {
      subst MID;
      intros ectx TCTX;
      simp[eval?];
      obtain out1 := IH1 TCTX;
      simp[out1.property];
      apply IH2;
      apply EvalContext.toTypingContext_bind TCTX;
      -- TODO: how to aesopify?
    }
    case single o WT IH => {
      intros ectx TCTX;
      simp[eval?];
      apply IH TCTX;
    }
}

-- 'Expr.eval?' returns a value that 'isSome' if the expression is well formed.
theorem Expr.eval?_isSome_if_expr_wellformed
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  {opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o}
  {pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i')}
  {ectx : EvalContext kindMotive}
  (TCTX: ectx.toTypingContext = tctx)
  {e : Expr ek k}
  (WT: ExprWellTyped tctx e) :
  (e.eval? opFold pairFold ectx).isSome := by {
    simp[Option.isSome];
    let val := Expr.eval?_succeeds_if_expr_wellformed TCTX WT (opFold := opFold) (pairFold := pairFold);
    simp[val.property];
}

-- Expression tree which produces a value of kind 'Kind'.
-- This is the initial algebra of the fold.
inductive OpenTree (kindMotive: Kind → Type) : Kind → Type where
| assign:  OpKind i o → OpenTree kindMotive i → OpenTree kindMotive o
| pair: OpenTree kindMotive a → OpenTree kindMotive b → OpenTree kindMotive (Kind.pair a b)
| var: {k: Kind} → kindMotive k → OpenTree kindMotive k

@[aesop norm unfold 1000]
def EvalContext.map
  {kindMotive: Kind → Type}
  {kindMotive': Kind → Type}
  (f: ∀ {k : Kind}, kindMotive k → kindMotive' k) -- naturality.
  : EvalContext kindMotive → EvalContext kindMotive' :=
  fun ectx k => match ectx k with
    | .none => .none
    | .some ⟨k, vk⟩ => .some ⟨k, f vk⟩

notation:max ectx " <$> " f => EvalContext.map f ectx

-- mapping preserves the typing context.
@[aesop safe]
theorem EvalContext.toTypingContext_map
  {kindMotive: Kind → Type}
  {kindMotive': Kind → Type}
  (ectx: EvalContext kindMotive)
  (f: ∀ {k : Kind}, kindMotive k → kindMotive' k)
  {tctx: TypingContext}
  (TCTX: EvalContext.toTypingContext ectx = tctx) :
  EvalContext.toTypingContext (ectx.map f) = tctx := by {
    subst TCTX;
    funext arg;
    cases H:(ectx arg) <;> simp[toTypingContext, EvalContext.map, H];
}

-- Convert a well typed 'Expr' into a value, as asked by 'kindMotive'
@[aesop norm unfold 1000]
def Expr.eval {ectx : EvalContext kindMotive}
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  {e: Expr ek k}
  {tctx: TypingContext}
  (TCTX: ectx.toTypingContext = tctx)
  (WT: ExprWellTyped tctx e): kindMotive k :=
  (e.eval? opFold pairFold ectx).get
    (Expr.eval?_isSome_if_expr_wellformed
      (opFold := opFold) (pairFold := pairFold)
      (TCTX := TCTX) (WT := WT))

notation "expr⟦⟧[" opFold ", " pairFold "," TCTX ", " WT " ⊧ " "⟦" e "⟧" "]" =>
  Expr.eval opFold pairFold TCTX WT (e := e)

-- Unfold `Expr.eval` for `Expr.ops`.
theorem Expr.eval_ops
  {kindMotive: Kind → Type} -- what each kind is compiled into.
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  (ectx ectx' : EvalContext kindMotive)
  (o1: Expr .O k1)
  (o2: Expr .Os k2)
  (tctx : TypingContext)
  (WT_OPS: ExprWellTyped tctx (Expr.ops o1 o2))
  (WT_OP1 : ExprWellTyped tctx o1)
  (WT_OP2: ExprWellTyped tctx' o2)
  (ECTX_TCTX: ectx.toTypingContext = tctx)
  (ECTX': ectx' = ectx.bind o1.retVar k1 (Expr.eval opFold pairFold (e := o1) (ectx := ectx) (tctx := tctx) ECTX_TCTX WT_OP1))
  (TCTX': tctx' = tctx.bind o1.retVar k1)
  (ECTX'_TCTX': ectx'.toTypingContext = tctx'):
  Expr.eval (k := k2)  opFold pairFold (e := Expr.ops o1 o2) (ectx := ectx) (tctx := tctx) ECTX_TCTX WT_OPS =
    @Expr.eval kindMotive ectx' opFold pairFold (e := o2)  (tctx := tctx') ECTX'_TCTX' WT_OP2 := by {
      subst ECTX';
      subst TCTX';
      simp[Expr.eval];
      simp[Expr.eval?_ops];
      congr;
      have E1VAL :
        expr⟦⟧?[fun {i o} => opFold, fun {i i'} => pairFold ; ectx ⊧ ⟦o1⟧] =
        Expr.eval opFold pairFold (e := o1) (ectx := ectx) (tctx := tctx) ECTX_TCTX WT_OP1 := by {
          simp[Expr.eval];
        };
      simp[E1VAL];
}

theorem Option.get_none_elim: (Option.get none P = v) → False := by aesop

-- show under what conditions eval? and 'eval' agree.
@[aesop unsafe, aesop forward safe]
theorem Expr.eval_implies_eval?
  {ectx : EvalContext kindMotive}
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  {e: Expr ek k}
  {TCTX: ectx.toTypingContext = tctx}
  {WT: ExprWellTyped tctx e} :
  (EVAL: Expr.eval opFold pairFold TCTX WT = v) →
  (e.eval? opFold pairFold ectx = .some v) := by aesop

-- Convert an expression to a tree by folding into the tree algebra
@[aesop norm unfold 1000]
def Expr.toOpenTree? (treectx: EvalContext (OpenTree kindMotive)) (e : Expr ek k): Option (OpenTree kindMotive k) :=
    e.eval?
        (opFold := fun opk ti => OpenTree.assign (kindMotive := kindMotive) opk ti)
        (pairFold := fun  ti ti' => OpenTree.pair (kindMotive := kindMotive) ti ti')
        treectx

notation "expr→tree?[" treectx " ; " e "]" => Expr.toOpenTree? treectx e

-- Convert an expression to a tree by folding into the tree algebra
@[aesop norm unfold 1000]
abbrev Expr.toOpenTree {treectx: EvalContext (OpenTree kindMotive)} {e : Expr ek k}
  (TCTX: treectx.toTypingContext = tctx)
  (WT: ExprWellTyped tctx e): OpenTree kindMotive k :=
    (e.eval
        (opFold := fun opk ti => OpenTree.assign opk ti)
        (pairFold := fun  ti ti' => OpenTree.pair ti ti')
        (tctx := tctx)
        (ectx := treectx)
        (TCTX := TCTX)
        (WT := WT))

notation "expr→tree[" TCTX "; " WT " ⊧ " e "]" => Expr.toOpenTree TCTX WT (e := e)

abbrev Expr.toOpenTree! (treectx: EvalContext! (OpenTree kindMotive))
    (e : Expr ek k)
    (default: (k: Kind) → kindMotive k): OpenTree kindMotive k :=
    e.eval!
        (opFold := fun opk ti => OpenTree.assign opk ti)
        (pairFold := fun  ti ti' => OpenTree.pair ti ti')
        (default := fun k => OpenTree.var (default k))
        treectx

-- theorem Expr.toOpenTree_eq_toOpenTree! (treectx: EvalContext! (OpenTree kindMotive))
--     (e : Expr ek k)
--     (default: (k: Kind) → kindMotive k)
--     {TCTX: treectx.toTypingContext = tctx}
--     {WP: ExprWellTyped tctx e}:
--     e.toOpenTree TCTX WP = e.toOpenTree! treectx default := by sorry

-- unfold a `toOpenTree` of `Expr.ops`
@[aesop norm]
def Expr.toOpenTree_ops
  (kindMotive: Kind → Type)
  (treectx treectx' : EvalContext (OpenTree kindMotive))
  (o1: Expr .O k1)
  (o2: Expr .Os k2)
  (WT_OPS: ExprWellTyped tctx (Expr.ops o1 o2))
  (WT_OP1 : ExprWellTyped tctx o1)
  (WT_OP2: ExprWellTyped tctx' o2)
  (TREECTX_TCTX: treectx.toTypingContext = tctx)
  (TREECTX': treectx' = treectx.bind o1.retVar k1 (o1.toOpenTree TREECTX_TCTX WT_OP1))
  (TCTX': tctx' = tctx.bind o1.retVar k1)
  (TREECTX'_TCTX':treectx'.toTypingContext = tctx') :
  (Expr.ops o1 o2).toOpenTree TREECTX_TCTX WT_OPS =
    o2.toOpenTree TREECTX'_TCTX' WT_OP2 := by {
      simp[toOpenTree];
      apply Expr.eval_ops <;> assumption;
}

-- we define 'Expr.eval', 'Expr.toTree', and 'Tree.eval' and show that the diagram below commutes:
-- Expr.eval = Tree.eval ∘ Expr.toTree
@[aesop norm unfold 1000]
def OpenTree.eval
  (kindMotive: Kind → Type)
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  : OpenTree kindMotive k → kindMotive k
  | .var v => v
  | .assign opk ti => opFold opk (ti.eval opFold pairFold)
  | .pair ta tb =>
      pairFold (ta.eval opFold pairFold) (tb.eval opFold pairFold)

notation "evaltree[" kindMotive ", " opFold "," pairFold " ⊧ " "⟦" tree "⟧" "]" => OpenTree.eval kindMotive opFold pairFold tree

-- In hindsight, it was probably easier to separately define evaluation and converting to a tree.
-- a tree context 'treectx' is valid iff it agrees with the value of 'ectx'
-- wherever ectx is evaluated.
-- TODO: this is a trashfire. It is not worth the "proof reuse" we get out of
-- this unification. As usual, @lyxsia has impeccable taste when it comes to dependent typing.
@[aesop safe, aesop forward safe, aesop cases safe]
structure ValidTreeContext
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  (ectx: EvalContext kindMotive) (treectx: EvalContext (OpenTree kindMotive))  where
    ectx_to_treectx :
        ∀ (key: String) (kind: Kind) (val: kindMotive kind),
          ectx key = .some ⟨kind, val⟩ →
        { treeval : OpenTree kindMotive kind //
          treectx key = .some ⟨kind, treeval⟩ ∧ OpenTree.eval kindMotive opFold pairFold treeval = val }
    treectx_to_ectx :
        ∀ (key: String) (kind: Kind) (treeval: OpenTree kindMotive kind),
          treectx key = .some ⟨kind, treeval⟩ →
          { val : kindMotive kind  //
              ectx key = .some ⟨kind, val⟩ ∧ OpenTree.eval kindMotive opFold pairFold treeval = val }

notation "ectx~treectx[" opFold ", " pairFold " ⊧ " ectx " ~ " treectx "]" =>
  ValidTreeContext opFold pairFold ectx treectx

-- #print Aesop.Options
set_option trace.aesop.steps true in
set_option trace.aesop.steps.tree true in
set_option trace.aesop.steps.normalization
 true in
@[aesop safe, aesop forward safe]
def ValidTreeContext.isTypingContext
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  (ectx: EvalContext kindMotive)
  {tctx: TypingContext}
  (TCTX: ectx.toTypingContext = tctx)
  {treectx: EvalContext (OpenTree kindMotive)}
  (TREECTX: ValidTreeContext opFold pairFold ectx treectx) :
  treectx.toTypingContext = tctx := by {
    simp[ValidTreeContext] at TREECTX;
    simp[EvalContext.toTypingContext] at TCTX ⊢;
    funext key;
    cases ECTX_KEY:(ectx key);
    case h.none => {
      -- if ectx is none, the treectx also must be none.
      -- if some, derive contradiction from 'TREECTX'.
      simp[ECTX_KEY];
      cases TREECTX_KEY:(treectx key) <;> simp[TREECTX_KEY];
      simp[← TCTX, ECTX_KEY];
      case some kind_and_treeval => {

        -- contradiction
        have ⟨kind, treeval⟩ := kind_and_treeval;
        -- aesop -- how to make aesop use treecx_to_ectx?

        -- this is kind of annoying, I need to evaluate the tree value
        -- to get that the value we have is a legitimate value.
        have ECTX_VAL := (TREECTX.treectx_to_ectx key kind treeval TREECTX_KEY);
        aesop -- we need aesop to make use TREEECTX.treectx_to_ectx.
      }
    }
    case h.some kind_val => {
      have ⟨kind, val⟩ := kind_val;
      have ⟨val_tree, TREE_KEY, TREE_EVAL⟩ := (TREECTX.ectx_to_treectx key kind val ECTX_KEY);
      aesop -- how to make aesop use TREE_KEY?
    }
  }

-- using (EvalContext.map var) provides a valid tree context.
@[aesop safe forward, aesop safe]
theorem ValidTreeContext.map_is_valid_tree_context
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  (ectx : EvalContext kindMotive):
  ValidTreeContext opFold pairFold ectx (ectx.map (OpenTree.var )) := by {
    constructor <;> aesop;
}

-- if `tree.eval = value`, then binding `key` to `tree` in `treectx` is maintains
-- the validity of the context
-- | This is un-aesopable.
@[aesop safe forward, aesop safe]
theorem ValidTreeContext.bind
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  {ectx : EvalContext kindMotive}
  {treectx: EvalContext (OpenTree kindMotive)}
  (TREECTX: ValidTreeContext opFold pairFold ectx treectx)
  (value: kindMotive kind)
  (tree: OpenTree kindMotive kind)
  (TREE: tree.eval opFold pairFold = value)
  (name: String) :
  ValidTreeContext opFold pairFold (ectx.bind name kind value) (treectx.bind name kind tree) := by {
  constructor;
  case ectx_to_treectx => {
    intros key kind val;
    intros H;
    simp at H ⊢;
    simp[ValidTreeContext, EvalContext.bind] at TREECTX H ⊢;
    by_cases KEY:(key = name);
    case pos => {
      subst KEY;
      simp at H  TREECTX ⊢;
      have ⟨KOP, EQ⟩ := H;
      subst KOP;
      subst EQ;
      simp at H TREECTX ⊢;
      apply Subtype.mk (val := tree) (property := by simp[TREE])
    }
    case neg => {
      simp[KEY] at H TREECTX ⊢;
      have H := TREECTX.ectx_to_treectx key kind val H;
      apply H;
    }
  }
  case treectx_to_ectx => {
    intros key kind tree;
    simp;
    intros TREECTX_KEY;

    simp [EvalContext.bind] at TREECTX_KEY TREECTX_KEY ⊢;
    by_cases KEY:(key = name);
    case pos => {
      subst KEY;
      simp at TREECTX_KEY ⊢;
      have ⟨KOP, VAR⟩ := TREECTX_KEY;
      subst KOP;
      simp at VAR ⊢;
      subst VAR;
      subst TREE;
      -- aesop -- TODO: aesop doesn't even work at the last step!
      apply Subtype.mk (val :=  evaltree[kindMotive, fun {i o} => opFold,fun {i i'} => pairFold ⊧ ⟦tree⟧])
                    (property := by simp);
    }
    case neg => {
      simp[KEY] at TREECTX_KEY ⊢;
      subst TREE;
      have H := TREECTX.treectx_to_ectx key kind tree TREECTX_KEY;
      simp at H;
      exact H;
    }
  }
}

-- the diagram commutes for open terms: Expr.eval = OpenTree.eval ∘ Expr.toOpenTree
-- for open terms, we need to add variables to our trees.
theorem OpenTree.eval_sound_open_op
  {ectx : EvalContext kindMotive}
  {e: Expr .O k}
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  {tctx: TypingContext}
  {treectx: EvalContext (OpenTree kindMotive)}
  (ECTX_TCTX: ↑ectx = tctx)
  (TREECTX_TCTX: treectx = tctx)
  (WT: ExprWellTyped tctx e)
  {TREECTX_ECTX: ValidTreeContext opFold pairFold ectx treectx}:
  (e.toOpenTree TREECTX_TCTX WT).eval opFold pairFold = e.eval opFold pairFold ECTX_TCTX WT := by {
    cases WT;
    case assign argk ret arg opkind ARG_WT RET_WT => {
      -- TODO: find a nice way to clean up the preimage/map/toTyping finagling.
      -- ARG:
      -- we have an ectx since the assignment is well typed
      have ⟨ectx_at_arg, ECTX_AT_ARG⟩ := EvalContext.toTypingContext_preimage_some ECTX_TCTX ARG_WT;
      -- since ectx ~ treectx, we have treeval that associates correctly with ectx_at_arg
      have ⟨tctx_at_arg, TCTX_AT_ARG, TCTX_AT_ARG_VAL⟩ :=
          TREECTX_ECTX.ectx_to_treectx arg argk ectx_at_arg ECTX_AT_ARG;
      simp[Expr.eval, Expr.toOpenTree, OpenTree.eval, Expr.eval?, EvalContext.lookupByKind];
      simp[ECTX_AT_ARG, TCTX_AT_ARG, TCTX_AT_ARG_VAL];
      -- RET:
      -- ectx, treectx at ret have none since we are well typed.
      have ECTX_AT_RET := EvalContext.toTypingContext_preimage_none ECTX_TCTX RET_WT;
      have TREECTX_AT_RET := EvalContext.toTypingContext_preimage_none TREECTX_TCTX RET_WT;
      simp[ECTX_AT_RET, TREECTX_AT_RET];
      simp[OpenTree.eval];
      -- COMMUTES:
      -- use correspondence between ectx and treectx to get the value of the argument.
      rw[←TCTX_AT_ARG_VAL];
    }
    case pair ret arg1 arg2 k1 k2 ARG1 ARG2 RET => {
      -- ARG1:
      -- we have an ectx since the assignment is well typed
      have ⟨ectx_at_arg1, ECTX_AT_ARG1⟩ := EvalContext.toTypingContext_preimage_some ECTX_TCTX ARG1;
      -- since ectx ~ treectx, we have treeval that associates correctly with ectx_at_arg
      have ⟨tctx_at_arg1, TCTX_AT_ARG1, TCTX_AT_ARG1_VAL⟩ :=
          TREECTX_ECTX.ectx_to_treectx arg1 k1 ectx_at_arg1 ECTX_AT_ARG1;
      simp[Expr.eval, Expr.toOpenTree, OpenTree.eval, Expr.eval?, EvalContext.lookupByKind];
      simp[ECTX_AT_ARG1, TCTX_AT_ARG1, TCTX_AT_ARG1_VAL];

      -- ARG2:
      -- we have an ectx since the assignment is well typed
      have ⟨ectx_at_arg2, ECTX_AT_ARG2⟩ := EvalContext.toTypingContext_preimage_some ECTX_TCTX ARG2;
      -- since ectx ~ treectx, we have treeval that associates correctly with ectx_at_arg
      have ⟨tctx_at_arg2, TCTX_AT_ARG2, TCTX_AT_ARG2_VAL⟩ :=
          TREECTX_ECTX.ectx_to_treectx arg2 k2 ectx_at_arg2 ECTX_AT_ARG2;
      simp[Expr.eval, Expr.toOpenTree, OpenTree.eval, Expr.eval?, EvalContext.lookupByKind];
      simp[ECTX_AT_ARG2, TCTX_AT_ARG2, TCTX_AT_ARG2_VAL];

      -- RET:
      -- ectx, treectx at ret have none since we are well typed.
      have ECTX_AT_RET := EvalContext.toTypingContext_preimage_none ECTX_TCTX RET;
      have TREECTX_AT_RET := EvalContext.toTypingContext_preimage_none TREECTX_TCTX RET;
      simp[ECTX_AT_RET, TREECTX_AT_RET];
      simp[OpenTree.eval];
      -- COMMUTES:
      -- use correspondence between ectx and treectx to get the value of the argument.
      rw[←TCTX_AT_ARG1_VAL, ← TCTX_AT_ARG2_VAL];
    }
  }

theorem OpenTree.eval_sound_open_ops
  {ectx : EvalContext kindMotive}
  {e: Expr .Os k}
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  {tctx: TypingContext}
  {treectx: EvalContext (OpenTree kindMotive)}
  (ECTX_TCTX: ↑ectx = tctx)
  (TREECTX_TCTX: treectx = tctx)
  (WT: ExprWellTyped tctx e)
  {TREECTX_ECTX: ValidTreeContext opFold pairFold ectx treectx}:
  (e.toOpenTree TREECTX_TCTX WT).eval opFold pairFold = e.eval opFold pairFold ECTX_TCTX WT :=
    match WT with
    | .ops (op1 := op1) (op2 := ops2) (ctxmid := ctxmid) (WT1 := WT1) (CTXMID := CTXMID) (WT2 := WT2) => by {
      rw[Expr.eval_ops (WT_OP1 := WT1) (WT_OP2 := WT2) (ECTX' := rfl) (TCTX' := by simp[CTXMID])
          (ECTX'_TCTX' := by {
            rw[← CTXMID];
            rw[EvalContext.toTypingContext_bind (TCTX := ECTX_TCTX)];
          }) ];
      rw[Expr.toOpenTree_ops (WT_OP1 := WT1) (WT_OP2 := WT2) (TREECTX_TCTX := TREECTX_TCTX) (TREECTX' := rfl) (TCTX' := by simp[CTXMID])
          (TREECTX'_TCTX' := by {
            rw[← CTXMID];
            rw[EvalContext.toTypingContext_bind (TCTX := TREECTX_TCTX)];
          })
        ];

      have EVAL_OP : (op1.toOpenTree TREECTX_TCTX _).eval opFold pairFold = op1.eval opFold pairFold ECTX_TCTX WT1 := by {
        apply OpenTree.eval_sound_open_op;
        assumption;
      }

      simp_rw[← EVAL_OP];
      simp;
      apply OpenTree.eval_sound_open_ops;
      apply ValidTreeContext.bind <;> try assumption;
      simp[EVAL_OP];
    }
    | .single (op := op) (WT := WT) => by {
      apply OpenTree.eval_sound_open_op <;> assumption
    }

-- evaluation of any operation is sound if the evalcontext and treecontext match.
theorem OpenTree.eval_sound
  {ectx : EvalContext kindMotive}
  {e: Expr ek k}
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  {tctx: TypingContext}
  {treectx: EvalContext (OpenTree kindMotive)}
  (ECTX_TCTX: ↑ectx = tctx)
  (TREECTX_TCTX: treectx = tctx)
  (WT: ExprWellTyped tctx e)
  {TREECTX_ECTX: ValidTreeContext opFold pairFold ectx treectx}:
  (e.toOpenTree TREECTX_TCTX WT).eval opFold pairFold = e.eval opFold pairFold ECTX_TCTX WT :=
  match ek with
  | .O => by { apply OpenTree.eval_sound_open_op; assumption; }
  | .Os => by { apply OpenTree.eval_sound_open_ops; assumption; }

-- main theorem: converting to an open tree and evaluating is sound
def diagram_commutes
  (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
  (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
  {ectx : EvalContext kindMotive}
  {e: Expr .Os k}
  (TCTX: ectx.toTypingContext = tctx)
  (WT: ExprWellTyped tctx e) :
  (e.toOpenTree (treectx := ectx.map OpenTree.var)
    (TCTX := EvalContext.toTypingContext_map _ _ TCTX) (WT := WT)).eval kindMotive opFold pairFold =
  e.eval opFold pairFold TCTX WT := by {
      have TREECTX := ValidTreeContext.map_is_valid_tree_context opFold pairFold ectx;
      apply OpenTree.eval_sound; assumption;
}

-- def diagram_commutes'
--   (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
--   (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
--   (default: (k: Kind) → kindMotive k)
--   {ectx : EvalContext kindMotive}
--   {e: Expr .Os k}
--   (TCTX: ectx.toTypingContext = tctx)
--   (WT: ExprWellTyped tctx e) :
--   (e.toOpenTree! (treectx := ectx.map OpenTree.var) default).eval kindMotive opFold pairFold =
--   e.eval opFold pairFold TCTX WT := by {
--       have TREECTX := ValidTreeContext.map_is_valid_tree_context opFold pairFold ectx;
--       sorry
--       -- apply OpenTree.eval_sound; assumption;
-- }

-- theorem Expr.eval_eq_eval!
--   (opFold: {i o: Kind} → OpKind i o → kindMotive i → kindMotive o)
--   (pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i'))
--   (default: (k: Kind) → kindMotive k)
--   {ectx : EvalContext kindMotive}
--   {e: Expr ek k}
--   (TCTX: ectx.toTypingContext = tctx)
--   (WT: ExprWellTyped tctx e) :
--   e.eval opFold pairFold TCTX WT = e.eval! opFold pairFold default ectx := by sorry

section EDSL

declare_syntax_cat dsl_op
declare_syntax_cat dsl_type
declare_syntax_cat dsl_ops
declare_syntax_cat dsl_region
declare_syntax_cat dsl_var
declare_syntax_cat dsl_var_name
declare_syntax_cat dsl_const
declare_syntax_cat dsl_kind

syntax sepBy1(ident, "×") :dsl_kind
syntax ident : dsl_var_name
syntax "%" dsl_var_name ":" dsl_kind : dsl_var
syntax dsl_var "="
      str
      ("("dsl_var ")")?
      ("[" dsl_region,* "]")?
      ("{" dsl_const "}")? ";": dsl_op
syntax "%" dsl_var_name "=" "tuple" "(" dsl_var "," dsl_var ")" ";": dsl_op
syntax num : dsl_const
syntax "{" ("^(" dsl_var ")" ":")?  dsl_op dsl_op*  "}" : dsl_region
syntax "[dsl_op|" dsl_op "]" : term
syntax "[dsl_ops|" dsl_op dsl_op* "]" : term
syntax "[dsl_region|" dsl_region "]" : term
syntax "[dsl_var|" dsl_var "]" : term
syntax "[dsl_kind|" dsl_kind "]" : term
syntax "[dsl_const|" dsl_const "]" : term
syntax "[dsl_var_name|" dsl_var_name "]" : term

-- @[simp]
-- def AST.Ops.fromList: Expr k1 → Expr k2 → Expr k2
-- | op, [] => .opsone op
-- | op, op'::ops => .opscons op (AST.Ops.fromList op' ops)

-- @[simp]
-- def AST.Regions.fromList: List Region → Regions
-- | [] => .regionsnil
-- | r :: rs => .regionscons r (AST.Regions.fromList rs)

open Lean Macro in
def parseKind (k: TSyntax `ident) : MacroM (TSyntax `term) :=
  match k.getId.toString with
  | "int" => `(AST.Kind.int)
  | "nat" => `(AST.Kind.nat)
  | unk => (Macro.throwErrorAt k s!"unknown kind '{unk}'")

open Lean Macro in
macro_rules
| `([dsl_kind| $[ $ks ]×* ]) => do
    if ks.isEmpty
    then `(AST.Kind.unit)
    else
      let mut out ← parseKind ks[ks.size - 1]!
      for k in ks.pop.reverse do
        let cur ← parseKind k
        out ← `(AST.Kind.pair $cur $out)
      return out
| `([dsl_kind| $$($q:term)]) => `(($q : Kind))

open Lean Macro in
macro_rules
| `([dsl_var_name| $name:ident ]) =>
      return (Lean.quote name.getId.toString : TSyntax `term)
| `([dsl_var_name| $$($q:term)]) => `(($q : String))

macro_rules
| `([dsl_var| %$name:dsl_var_name : $kind:dsl_kind]) => do
    `({ name := [dsl_var_name| $name],
        kind := [dsl_kind| $kind] : Var})
| `([dsl_var| $$($q:term)]) => `(($q : Var))

macro_rules
| `([dsl_ops| $op $ops*]) => do
   let op_term ← `([dsl_op| $op])
   let ops_term ← ops.mapM (fun op => `([dsl_op| $op ]))
   `(AST.Ops.fromList $op_term [ $ops_term,* ])

macro_rules
| `([dsl_ops| $$($q)]) => `(($q : Ops))

-- macro_rules
-- | `([dsl_region| { $[ ^( $arg:dsl_var ): ]? $op $ops* } ]) => do
--    let ops ← `([dsl_ops| $op $ops*])
--    match arg with
--    | .none => `(Expr.region Var.unit $ops)
--    | .some arg => do
--       let arg_term ← `([dsl_var| $arg ])
--       `(Expr.region $arg_term $ops)
-- | `([dsl_region| $$($q)]) => `(($q : Region))

-- macro_rules
-- | `([dsl_const| $x:num ]) => `(Const.int $x)
-- | `([dsl_const| $$($q)]) => `(($q : Const))

-- open Lean Syntax in
-- macro_rules
-- | `([dsl_op| $res:dsl_var = $name:str
--       $[ ( $arg:dsl_var ) ]?
--       $[ [ $rgns,* ] ]?
--       $[ { $const } ]?
--       ;
--       ]) => do
--       let res_term ← `([dsl_var| $res])
--       let arg_term ← match arg with
--           | .some arg => `([dsl_var| $arg])
--           | .none => `(AST.Var.unit)
--       let name_term := name
--       let rgns_term ← match rgns with
--         | .none => `(.regionsnil)
--         | .some rgns =>
--            let rgns ← rgns.getElems.mapM (fun stx => `([dsl_region| $stx]))
--            `(AST.Regions.fromList [ $rgns,* ])
--       let const_term ←
--         match const with
--         | .none => `(Const.unit)
--         | .some c => `([dsl_const| $c])
--       `(Expr.op $res_term (OpName.fromString ($name_term : String)) $arg_term $rgns_term $const_term)
-- | `([dsl_op| $$($q)]) => `(($q : Op))

-- macro_rules
-- | `([dsl_op| %$res:dsl_var_name = tuple ( $arg1:dsl_var , $arg2:dsl_var) ; ]) => do
--     let res_term ← `([dsl_var_name| $res])
--     let arg1_term ← `([dsl_var| $arg1 ])
--     let arg2_term ← `([dsl_var| $arg2 ])
--     `(Expr.tuple $res_term $arg1_term $arg2_term)

end EDSL

section Examples

@[simp, reducible]
def Kind.eval : Kind → Type
| .int => Int
| .pair k1 k2 => k1.eval × k2.eval
| .unit => Unit

def OpKind.opFold {i o : Kind}: OpKind i o → i.eval → o.eval
| .add, (x, y) => x + y
| .sub, (x, y) => x - y
| .negate, x => -x
| .const, () => 0 -- this is cheating, but whatever.

def OpKind.pairFold {i i' : Kind}: i.eval → i'.eval → (Kind.pair i i').eval
| x, y => (x, y)

structure ExprRewrite where
  kindMotive : Kind → Type
  opFold {i o: Kind}: OpKind i o → kindMotive i → kindMotive o
  pairFold: {i i': Kind} → kindMotive i → kindMotive i' → kindMotive (Kind.pair i i')
  default : (k: Kind) → kindMotive k
  k : Kind
  find : Expr .Os k
  replace : Expr .Os k
  tctx : TypingContext
  WT_FIND : ExprWellTyped tctx find -- the find pattern is well typed at tctx.
  WT_REPLACE : ExprWellTyped tctx replace
  -- A rewrite is correct iff for every evaluation context where the
  -- exprsesion is well typed, the result of evaluating the find pattern equals
  -- the replace pattern.
  REWRITE : ∀ (ectx : EvalContext! kindMotive),
    find.eval! opFold pairFold default ectx = replace.eval! opFold pairFold default ectx

def Kind.eval_default (k: Kind): k.eval :=
  match k with
  | .int => 0
  | .pair k1 k2 => (k1.eval_default, k2.eval_default)
  | .unit => ()

-- failed to compile definition, consider marking it as 'noncomputable' because it depends on
-- 'ToTree.ExprWellTyped.compute_implies_prop', and it does not have executable code
noncomputable def sub_x_x_equals_zero : ExprRewrite where
  kindMotive := Kind.eval
  opFold := OpKind.opFold
  pairFold := OpKind.pairFold
  default := Kind.eval_default
  k := .int
  find := Expr.ops
          (Expr.pair "x_x" "x" .int "x" .int)
          (Expr.single (Expr.assign "y" .sub "x_x"))
  replace := Expr.single (Expr.assign "y" .const "_")
  tctx := TypingContext.bottom [ "x" ↦ .int] ["_" ↦ .unit]
  WT_FIND := by {
    apply ExprWellTyped.compute_implies_prop; -- convert theorem into computation.
    simp; -- crunch!
  }
  WT_REPLACE := by {
    apply ExprWellTyped.compute_implies_prop; -- convert theorem into computation,
    simp; -- crunch?
  }
  REWRITE := by {
    intros ectx;
    simp only[dite_eq_ite, Expr.eval!, ite_true, OpKind.opFold, EvalContext!.bind, OpKind.pairFold];
    apply sub_self;
  }

end Examples

end ToTree

def main : IO UInt32 := do
  IO.println "Hello, tree!"
  pure 0


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module combinatorics.double_counting
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.BigOperators.Order

/-!
# Double countings

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

This file gathers a few double counting arguments.

## Bipartite graphs

In a bipartite graph (considered as a relation `r : α → β → Prop`), we can bound the number of edges
between `s : finset α` and `t : finset β` by the minimum/maximum of edges over all `a ∈ s` times the
the size of `s`. Similarly for `t`. Combining those two yields inequalities between the sizes of `s`
and `t`.

* `bipartite_below`: `s.bipartite_below r b` are the elements of `s` below `b` wrt to `r`. Its size
  is the number of edges of `b` in `s`.
* `bipartite_above`: `t.bipartite_above r a` are the elements of `t` above `a` wrt to `r`. Its size
  is the number of edges of `a` in `t`.
* `card_mul_le_card_mul`, `card_mul_le_card_mul'`: Double counting the edges of a bipartite graph
  from below and from above.
* `card_mul_eq_card_mul`: Equality combination of the previous.
-/

open Finset Function Relator

open BigOperators

variable {α β : Type _}

/-! ### Bipartite graph -/

namespace Finset

section Bipartite

variable (r : α → β → Prop) (s : Finset α) (t : Finset β) (a a' : α) (b b' : β)
  [DecidablePred (r a)] [∀ a, Decidable (r a b)] {m n : ℕ}

#print Finset.bipartiteBelow /-
/-- Elements of `s` which are "below" `b` according to relation `r`. -/
def bipartiteBelow : Finset α :=
  s.filterₓ fun a => r a b
#align finset.bipartite_below Finset.bipartiteBelow
-/

#print Finset.bipartiteAbove /-
/-- Elements of `t` which are "above" `a` according to relation `r`. -/
def bipartiteAbove : Finset β :=
  t.filterₓ (r a)
#align finset.bipartite_above Finset.bipartiteAbove
-/

#print Finset.bipartiteBelow_swap /-
theorem bipartiteBelow_swap : t.bipartiteBelow (swap r) a = t.bipartiteAbove r a :=
  rfl
#align finset.bipartite_below_swap Finset.bipartiteBelow_swap
-/

/- warning: finset.bipartite_above_swap -> Finset.bipartiteAbove_swap is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> β -> Prop) (s : Finset.{u1} α) (b : β) [_inst_2 : forall (a : α), Decidable (r a b)], Eq.{succ u1} (Finset.{u1} α) (Finset.bipartiteAbove.{u2, u1} β α (Function.swap.{succ u1, succ u2, 1} α β (fun (ᾰ : α) (ᾰ : β) => Prop) r) s b (fun (a : α) => _inst_2 a)) (Finset.bipartiteBelow.{u1, u2} α β r s b (fun (a : α) => _inst_2 a))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> β -> Prop) (s : Finset.{u2} α) (b : β) [_inst_2 : forall (a : α), Decidable (r a b)], Eq.{succ u2} (Finset.{u2} α) (Finset.bipartiteAbove.{u1, u2} β α (Function.swap.{succ u2, succ u1, 1} α β (fun (ᾰ : α) (ᾰ : β) => Prop) r) s b (fun (a : α) => _inst_2 a)) (Finset.bipartiteBelow.{u2, u1} α β r s b (fun (a : α) => _inst_2 a))
Case conversion may be inaccurate. Consider using '#align finset.bipartite_above_swap Finset.bipartiteAbove_swapₓ'. -/
theorem bipartiteAbove_swap : s.bipartiteAbove (swap r) b = s.bipartiteBelow r b :=
  rfl
#align finset.bipartite_above_swap Finset.bipartiteAbove_swap

/- warning: finset.coe_bipartite_below -> Finset.coe_bipartiteBelow is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> β -> Prop) (s : Finset.{u1} α) (b : β) [_inst_2 : forall (a : α), Decidable (r a b)], Eq.{succ u1} (Set.{u1} α) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Finset.{u1} α) (Set.{u1} α) (HasLiftT.mk.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (Finset.Set.hasCoeT.{u1} α))) (Finset.bipartiteBelow.{u1, u2} α β r s b (fun (a : α) => _inst_2 a))) (Sep.sep.{u1, u1} α (Set.{u1} α) (Set.hasSep.{u1} α) (fun (a : α) => r a b) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Finset.{u1} α) (Set.{u1} α) (HasLiftT.mk.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (Finset.Set.hasCoeT.{u1} α))) s))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> β -> Prop) (s : Finset.{u2} α) (b : β) [_inst_2 : forall (a : α), Decidable (r a b)], Eq.{succ u2} (Set.{u2} α) (Finset.toSet.{u2} α (Finset.bipartiteBelow.{u2, u1} α β r s b (fun (a : α) => _inst_2 a))) (setOf.{u2} α (fun (a : α) => And (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a s) (r a b)))
Case conversion may be inaccurate. Consider using '#align finset.coe_bipartite_below Finset.coe_bipartiteBelowₓ'. -/
@[simp, norm_cast]
theorem coe_bipartiteBelow : (s.bipartiteBelow r b : Set α) = { a ∈ s | r a b } :=
  coe_filter _ _
#align finset.coe_bipartite_below Finset.coe_bipartiteBelow

#print Finset.coe_bipartiteAbove /-
@[simp, norm_cast]
theorem coe_bipartiteAbove : (t.bipartiteAbove r a : Set β) = { b ∈ t | r a b } :=
  coe_filter _ _
#align finset.coe_bipartite_above Finset.coe_bipartiteAbove
-/

variable {s t a a' b b'}

/- warning: finset.mem_bipartite_below -> Finset.mem_bipartiteBelow is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> β -> Prop) {s : Finset.{u1} α} {b : β} [_inst_2 : forall (a : α), Decidable (r a b)] {a : α}, Iff (Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a (Finset.bipartiteBelow.{u1, u2} α β r s b (fun (a : α) => _inst_2 a))) (And (Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a s) (r a b))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> β -> Prop) {s : Finset.{u2} α} {b : β} [_inst_2 : forall (a : α), Decidable (r a b)] {a : α}, Iff (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a (Finset.bipartiteBelow.{u2, u1} α β r s b (fun (a : α) => _inst_2 a))) (And (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a s) (r a b))
Case conversion may be inaccurate. Consider using '#align finset.mem_bipartite_below Finset.mem_bipartiteBelowₓ'. -/
@[simp]
theorem mem_bipartiteBelow {a : α} : a ∈ s.bipartiteBelow r b ↔ a ∈ s ∧ r a b :=
  mem_filter
#align finset.mem_bipartite_below Finset.mem_bipartiteBelow

#print Finset.mem_bipartiteAbove /-
@[simp]
theorem mem_bipartiteAbove {b : β} : b ∈ t.bipartiteAbove r a ↔ b ∈ t ∧ r a b :=
  mem_filter
#align finset.mem_bipartite_above Finset.mem_bipartiteAbove
-/

/- warning: finset.sum_card_bipartite_above_eq_sum_card_bipartite_below -> Finset.sum_card_bipartiteAbove_eq_sum_card_bipartiteBelow is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> β -> Prop) {s : Finset.{u1} α} {t : Finset.{u2} β} [_inst_3 : forall (a : α) (b : β), Decidable (r a b)], Eq.{1} Nat (Finset.sum.{0, u1} Nat α Nat.addCommMonoid s (fun (a : α) => Finset.card.{u2} β (Finset.bipartiteAbove.{u1, u2} α β r t a (fun (a_1 : β) => _inst_3 a a_1)))) (Finset.sum.{0, u2} Nat β Nat.addCommMonoid t (fun (b : β) => Finset.card.{u1} α (Finset.bipartiteBelow.{u1, u2} α β r s b (fun (a : α) => _inst_3 a b))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> β -> Prop) {s : Finset.{u2} α} {t : Finset.{u1} β} [_inst_3 : forall (a : α) (b : β), Decidable (r a b)], Eq.{1} Nat (Finset.sum.{0, u2} Nat α Nat.addCommMonoid s (fun (a : α) => Finset.card.{u1} β (Finset.bipartiteAbove.{u2, u1} α β r t a (fun (a_1 : β) => _inst_3 a a_1)))) (Finset.sum.{0, u1} Nat β Nat.addCommMonoid t (fun (b : β) => Finset.card.{u2} α (Finset.bipartiteBelow.{u2, u1} α β r s b (fun (a : α) => _inst_3 a b))))
Case conversion may be inaccurate. Consider using '#align finset.sum_card_bipartite_above_eq_sum_card_bipartite_below Finset.sum_card_bipartiteAbove_eq_sum_card_bipartiteBelowₓ'. -/
theorem sum_card_bipartiteAbove_eq_sum_card_bipartiteBelow [∀ a b, Decidable (r a b)] :
    (∑ a in s, (t.bipartiteAbove r a).card) = ∑ b in t, (s.bipartiteBelow r b).card :=
  by
  simp_rw [card_eq_sum_ones, bipartite_above, bipartite_below, sum_filter]
  exact sum_comm
#align finset.sum_card_bipartite_above_eq_sum_card_bipartite_below Finset.sum_card_bipartiteAbove_eq_sum_card_bipartiteBelow

/- warning: finset.card_mul_le_card_mul -> Finset.card_mul_le_card_mul is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> β -> Prop) {s : Finset.{u1} α} {t : Finset.{u2} β} {m : Nat} {n : Nat} [_inst_3 : forall (a : α) (b : β), Decidable (r a b)], (forall (a : α), (Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a s) -> (LE.le.{0} Nat Nat.hasLe m (Finset.card.{u2} β (Finset.bipartiteAbove.{u1, u2} α β r t a (fun (a_1 : β) => _inst_3 a a_1))))) -> (forall (b : β), (Membership.Mem.{u2, u2} β (Finset.{u2} β) (Finset.hasMem.{u2} β) b t) -> (LE.le.{0} Nat Nat.hasLe (Finset.card.{u1} α (Finset.bipartiteBelow.{u1, u2} α β r s b (fun (a : α) => _inst_3 a b))) n)) -> (LE.le.{0} Nat Nat.hasLe (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (Finset.card.{u1} α s) m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (Finset.card.{u2} β t) n))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> β -> Prop) {s : Finset.{u2} α} {t : Finset.{u1} β} {m : Nat} {n : Nat} [_inst_3 : forall (a : α) (b : β), Decidable (r a b)], (forall (a : α), (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a s) -> (LE.le.{0} Nat instLENat m (Finset.card.{u1} β (Finset.bipartiteAbove.{u2, u1} α β r t a (fun (a_1 : β) => _inst_3 a a_1))))) -> (forall (b : β), (Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) b t) -> (LE.le.{0} Nat instLENat (Finset.card.{u2} α (Finset.bipartiteBelow.{u2, u1} α β r s b (fun (a : α) => _inst_3 a b))) n)) -> (LE.le.{0} Nat instLENat (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (Finset.card.{u2} α s) m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (Finset.card.{u1} β t) n))
Case conversion may be inaccurate. Consider using '#align finset.card_mul_le_card_mul Finset.card_mul_le_card_mulₓ'. -/
/-- Double counting argument. Considering `r` as a bipartite graph, the LHS is a lower bound on the
number of edges while the RHS is an upper bound. -/
theorem card_mul_le_card_mul [∀ a b, Decidable (r a b)]
    (hm : ∀ a ∈ s, m ≤ (t.bipartiteAbove r a).card)
    (hn : ∀ b ∈ t, (s.bipartiteBelow r b).card ≤ n) : s.card * m ≤ t.card * n :=
  calc
    _ ≤ ∑ a in s, (t.bipartiteAbove r a).card := s.card_nsmul_le_sum _ _ hm
    _ = ∑ b in t, (s.bipartiteBelow r b).card :=
      (sum_card_bipartiteAbove_eq_sum_card_bipartiteBelow _)
    _ ≤ _ := t.sum_le_card_nsmul _ _ hn

#align finset.card_mul_le_card_mul Finset.card_mul_le_card_mul

#print Finset.card_mul_le_card_mul' /-
theorem card_mul_le_card_mul' [∀ a b, Decidable (r a b)]
    (hn : ∀ b ∈ t, n ≤ (s.bipartiteBelow r b).card)
    (hm : ∀ a ∈ s, (t.bipartiteAbove r a).card ≤ m) : t.card * n ≤ s.card * m :=
  card_mul_le_card_mul (swap r) hn hm
#align finset.card_mul_le_card_mul' Finset.card_mul_le_card_mul'
-/

/- warning: finset.card_mul_eq_card_mul -> Finset.card_mul_eq_card_mul is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> β -> Prop) {s : Finset.{u1} α} {t : Finset.{u2} β} {m : Nat} {n : Nat} [_inst_3 : forall (a : α) (b : β), Decidable (r a b)], (forall (a : α), (Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a s) -> (Eq.{1} Nat (Finset.card.{u2} β (Finset.bipartiteAbove.{u1, u2} α β r t a (fun (a_1 : β) => _inst_3 a a_1))) m)) -> (forall (b : β), (Membership.Mem.{u2, u2} β (Finset.{u2} β) (Finset.hasMem.{u2} β) b t) -> (Eq.{1} Nat (Finset.card.{u1} α (Finset.bipartiteBelow.{u1, u2} α β r s b (fun (a : α) => _inst_3 a b))) n)) -> (Eq.{1} Nat (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (Finset.card.{u1} α s) m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (Finset.card.{u2} β t) n))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> β -> Prop) {s : Finset.{u2} α} {t : Finset.{u1} β} {m : Nat} {n : Nat} [_inst_3 : forall (a : α) (b : β), Decidable (r a b)], (forall (a : α), (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a s) -> (Eq.{1} Nat (Finset.card.{u1} β (Finset.bipartiteAbove.{u2, u1} α β r t a (fun (a_1 : β) => _inst_3 a a_1))) m)) -> (forall (b : β), (Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) b t) -> (Eq.{1} Nat (Finset.card.{u2} α (Finset.bipartiteBelow.{u2, u1} α β r s b (fun (a : α) => _inst_3 a b))) n)) -> (Eq.{1} Nat (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (Finset.card.{u2} α s) m) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (Finset.card.{u1} β t) n))
Case conversion may be inaccurate. Consider using '#align finset.card_mul_eq_card_mul Finset.card_mul_eq_card_mulₓ'. -/
theorem card_mul_eq_card_mul [∀ a b, Decidable (r a b)]
    (hm : ∀ a ∈ s, (t.bipartiteAbove r a).card = m)
    (hn : ∀ b ∈ t, (s.bipartiteBelow r b).card = n) : s.card * m = t.card * n :=
  (card_mul_le_card_mul _ (fun a ha => (hm a ha).ge) fun b hb => (hn b hb).le).antisymm <|
    card_mul_le_card_mul' _ (fun a ha => (hn a ha).ge) fun b hb => (hm b hb).le
#align finset.card_mul_eq_card_mul Finset.card_mul_eq_card_mul

/- warning: finset.card_le_card_of_forall_subsingleton -> Finset.card_le_card_of_forall_subsingleton is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (r : α -> β -> Prop) {s : Finset.{u1} α} {t : Finset.{u2} β}, (forall (a : α), (Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) a s) -> (Exists.{succ u2} β (fun (b : β) => And (Membership.Mem.{u2, u2} β (Finset.{u2} β) (Finset.hasMem.{u2} β) b t) (r a b)))) -> (forall (b : β), (Membership.Mem.{u2, u2} β (Finset.{u2} β) (Finset.hasMem.{u2} β) b t) -> (Set.Subsingleton.{u1} α (Sep.sep.{u1, u1} α (Set.{u1} α) (Set.hasSep.{u1} α) (fun (a : α) => r a b) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Finset.{u1} α) (Set.{u1} α) (HasLiftT.mk.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (Finset.Set.hasCoeT.{u1} α))) s)))) -> (LE.le.{0} Nat Nat.hasLe (Finset.card.{u1} α s) (Finset.card.{u2} β t))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (r : α -> β -> Prop) {s : Finset.{u2} α} {t : Finset.{u1} β}, (forall (a : α), (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a s) -> (Exists.{succ u1} β (fun (b : β) => And (Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) b t) (r a b)))) -> (forall (b : β), (Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) b t) -> (Set.Subsingleton.{u2} α (setOf.{u2} α (fun (a : α) => And (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) a s) (r a b))))) -> (LE.le.{0} Nat instLENat (Finset.card.{u2} α s) (Finset.card.{u1} β t))
Case conversion may be inaccurate. Consider using '#align finset.card_le_card_of_forall_subsingleton Finset.card_le_card_of_forall_subsingletonₓ'. -/
theorem card_le_card_of_forall_subsingleton (hs : ∀ a ∈ s, ∃ b, b ∈ t ∧ r a b)
    (ht : ∀ b ∈ t, ({ a ∈ s | r a b } : Set α).Subsingleton) : s.card ≤ t.card := by
  classical simpa using
      card_mul_le_card_mul _
        (fun a h =>
          card_pos.2 <|
            (by
              rw [← coe_nonempty, coe_bipartite_above]
              exact hs _ h : (t.bipartite_above r a).Nonempty))
        fun b h =>
        card_le_one.2 <| by
          simp_rw [mem_bipartite_below]
          exact ht _ h
#align finset.card_le_card_of_forall_subsingleton Finset.card_le_card_of_forall_subsingleton

#print Finset.card_le_card_of_forall_subsingleton' /-
theorem card_le_card_of_forall_subsingleton' (ht : ∀ b ∈ t, ∃ a, a ∈ s ∧ r a b)
    (hs : ∀ a ∈ s, ({ b ∈ t | r a b } : Set β).Subsingleton) : t.card ≤ s.card :=
  card_le_card_of_forall_subsingleton (swap r) ht hs
#align finset.card_le_card_of_forall_subsingleton' Finset.card_le_card_of_forall_subsingleton'
-/

end Bipartite

end Finset

open Finset

namespace Fintype

variable [Fintype α] [Fintype β] {r : α → β → Prop}

/- warning: fintype.card_le_card_of_left_total_unique -> Fintype.card_le_card_of_leftTotal_unique is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : Fintype.{u2} β] {r : α -> β -> Prop}, (Relator.LeftTotal.{u1, u2} α β r) -> (Relator.LeftUnique.{u1, u2} α β r) -> (LE.le.{0} Nat Nat.hasLe (Fintype.card.{u1} α _inst_1) (Fintype.card.{u2} β _inst_2))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : Fintype.{u1} β] {r : α -> β -> Prop}, (Relator.LeftTotal.{u2, u1} α β r) -> (Relator.LeftUnique.{u2, u1} α β r) -> (LE.le.{0} Nat instLENat (Fintype.card.{u2} α _inst_1) (Fintype.card.{u1} β _inst_2))
Case conversion may be inaccurate. Consider using '#align fintype.card_le_card_of_left_total_unique Fintype.card_le_card_of_leftTotal_uniqueₓ'. -/
theorem card_le_card_of_leftTotal_unique (h₁ : LeftTotal r) (h₂ : LeftUnique r) :
    Fintype.card α ≤ Fintype.card β :=
  card_le_card_of_forall_subsingleton r (by simpa using h₁) fun b _ a₁ ha₁ a₂ ha₂ => h₂ ha₁.2 ha₂.2
#align fintype.card_le_card_of_left_total_unique Fintype.card_le_card_of_leftTotal_unique

/- warning: fintype.card_le_card_of_right_total_unique -> Fintype.card_le_card_of_rightTotal_unique is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : Fintype.{u2} β] {r : α -> β -> Prop}, (Relator.RightTotal.{u1, u2} α β r) -> (Relator.RightUnique.{u1, u2} α β r) -> (LE.le.{0} Nat Nat.hasLe (Fintype.card.{u2} β _inst_2) (Fintype.card.{u1} α _inst_1))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : Fintype.{u1} β] {r : α -> β -> Prop}, (Relator.RightTotal.{u2, u1} α β r) -> (Relator.RightUnique.{u2, u1} α β r) -> (LE.le.{0} Nat instLENat (Fintype.card.{u1} β _inst_2) (Fintype.card.{u2} α _inst_1))
Case conversion may be inaccurate. Consider using '#align fintype.card_le_card_of_right_total_unique Fintype.card_le_card_of_rightTotal_uniqueₓ'. -/
theorem card_le_card_of_rightTotal_unique (h₁ : RightTotal r) (h₂ : RightUnique r) :
    Fintype.card β ≤ Fintype.card α :=
  card_le_card_of_forall_subsingleton' r (by simpa using h₁) fun b _ a₁ ha₁ a₂ ha₂ => h₂ ha₁.2 ha₂.2
#align fintype.card_le_card_of_right_total_unique Fintype.card_le_card_of_rightTotal_unique

end Fintype


/-
Copyright (c) 2016 Leonardo de Moura. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.set.lattice

/-!
# Functoriality of `set`

This file defines the functor structure of `set`.
-/

universes u

open function

namespace set
variables {α β : Type u} {s : set α} {f : α → set β} {g : set (α → β)}

instance : monad.{u} set :=
{ pure       := λ α a, {a},
  bind       := λ α β s f, ⋃ i ∈ s, f i,
  seq        := λ α β, set.seq,
  map        := λ α β, set.image }

@[simp] lemma bind_def : s >>= f = ⋃ i ∈ s, f i := rfl
@[simp] lemma fmap_eq_image (f : α → β) : f <$> s = f '' s := rfl
@[simp] lemma seq_eq_set_seq (s : set (α → β)) (t : set α) : s <*> t = s.seq t := rfl
@[simp] lemma pure_def (a : α) : (pure a : set α) = {a} := rfl

instance : is_lawful_monad set :=
{ pure_bind             := λ α β x f, by simp,
  bind_assoc            := λ α β γ s f g, set.ext $ λ a,
    by simp [exists_and_distrib_right.symm, -exists_and_distrib_right,
             exists_and_distrib_left.symm, -exists_and_distrib_left, and_assoc];
       exact exists_swap,
  id_map                := λ α, id_map,
  bind_pure_comp_eq_map := λ α β f s, set.ext $ by simp [set.image, eq_comm],
  bind_map_eq_seq       := λ α β s t, by simp [seq_def] }

instance : is_comm_applicative (set : Type u → Type u) :=
⟨ λ α β s t, prod_image_seq_comm s t ⟩

instance : alternative set :=
{ orelse := λ α, (∪),
  failure := λ α, ∅,
  .. set.monad }

end set