-- A basic framework for graph theory on multidigraphs in Lean
-- and a proof that no_watershed_condition is sufficient to
-- establish that a graph has a unique sink for each vertex
--
-- I hope to give some introduction to the syntax of how Lean works here,
-- but I assume some familiarity with functions, pattern matching,
-- type theory, and proofs.
--
-- The most important thing to note is that `begin` and `end` delineate
-- sections of code in "tactic/interactive proof mode" (as opposed to
-- "term mode"). The Lean compiler shows the proof goal and the available
-- assumptions and context, and then shows how it changes after tactics
-- are executed. The best way to see this happen is to download Lean from
-- the following links and open it in VSCode (or emacs) and walk through
-- the steps of a proof to see the changes.
--
-- VSCode: "Typing ctrl-shift-enter opens up a message window which shows you
-- error messages, warnings, output, and goal information when in tactic mode."
-- Emacs: "C-c C-g	show goal in tactic proof (lean-show-goal-at-pos)"
-- (https://leanprover.github.io/reference/using_lean.html)
--
-- Make sure to create a project folder and install mathlib as explained here:
-- https://leanprover.github.io/reference/using_lean.html#using-the-package-manager
--
-- http://leanprover.github.io/
-- https://github.com/leanprover/lean

-- Quick primer on Lean:
--
-- Propositions are types. This means that the mathematical language of Lean is
-- the language of types, which can encode any sensical sentence about math.
-- Types are, of course, also used in the design of computable programming
-- languages, which Lean also is. But "mere" propositions don't contain data
-- to compute on: only the type of a proof matters, really, not its exact details.
--
-- The term language and the type language are the same, which means that values
-- can be mentioned in types, and vice-versa. This is a result of dependent type
-- theory, and it allows encoding interesting propositions, such as about the value
-- of functions: given some (f : ℝ → ℝ), (∀ x : ℝ, x > 0 → f x = 0) is the
-- proposition that, for positive values of `x`, `f x` evaluates to zero. Note that
-- `f` is a fixed value, and `x` is a variable value, both mentioned at the type level.
--
-- ∀ is actually the same thing as Π – they are notation for dependently-typed
-- functions. (f : Π (a : α), β a) is a function that takes an element `a` of type `α`
-- and returns a result that `β a`, with a type that can depend on the value of `a`.
-- Putting this together, if we have `f` as above, and some `v : α`, then `f v : β v`
-- (meaning, the value of `f` applied to `v` has type `β v`).
-- If `β a` does _not_ depend on `a` (that is, if `β` is a constant function, say,
-- β = λ _, γ), then the type of `f` can be written as `α → γ`, the type of a
-- non-dependent function, also familiar as implication from logic.
-- The cool bit about dependent functions, though, is that they are also used to
-- introduce polymorphism, if `α` is chosen to be `Type` (or `Prop`, or `Sort u`
-- most generally). So `(λ _ a, a) : ∀ {α : Type}, α → α` is the polymorphic
-- identity function. Note that function terms are introduced with lambdas:
--    def f : Π (a : α), β a :=
--      λ (a : α), <some value of type `β a` using `a : α` in scope>
--
-- But more typically, top-level definitions will have this alternate syntax:
--    def f (a : α) : β a := <some value of type `β a` using `a : α` in scope>
-- There are subtle differences, but they are basically the same, just note
-- that in this latter form, (a : α) is already in scope without the lambda binder!
--
-- I mention this below, but for completeness, there is existential quantification:
-- (∃ (a : α), p a) : Prop, and dependent products: (Σ' (a : α), p a) : Type.
-- Dependent products give access to the value and the proof, whereas existentials
-- only assert that there is such a value, without giving it explicitly.
-- This is the difference between (non-computable) classical logic and (computable)
-- intuitionistic logic. See https://homotopytypetheory.org/book/ for more.
--
-- Definitional versus propositional equality: there are two varieties of equality:
-- `:=` is the syntax used to declare equalities, most of the time, and
-- `=` is the proposition that two things are equal. The Lean compiler will solve
-- definitional equalities, and this can be turned into a propositional equality
-- using `refl a : a = a` (standing for the reflexivity of equality).
-- For example, `refl 1 : 1 = 1` is the proof that 1 equals itself. Duh!
-- `eq.trans (e1 : a = b) (e2 : b = c) : a = c` is an example where, even though
-- `a`, `b`, and `c` are not known in advance (and thus are not definitionally
-- equal), their propositional equalities can still be combined.

-- Import libraries that this file depends on
import data.fintype.basic data.equiv.basic

-- Just a universe variable (used to avoid Girard's/Russel's paradox).
-- Not so important; see the following for more:
-- https://leanprover.github.io/reference/other_commands.html
-- https://en.wikipedia.org/wiki/Intuitionistic_type_theory#Universe_Types
universe u

-- A few helpful lemmata, explanations skipped
theorem psigma_elim_exists {α : Type} {β : α → Prop} {r : Prop} :
    Exists β → (psigma β → r) → r :=
        λ e f, exists.elim e (λ a b, f (psigma.mk a b))

theorem subtype_elim_exists {α : Type} {β : α → Prop} {r : Prop} :
    Exists β → (subtype β → r) → r :=
        λ e f, exists.elim e (λ a b, f (subtype.mk a b))

lemma list.nodup_tail_of_nodup {α : Type} {l : list α} :
    list.nodup l → list.nodup (list.tail l) :=
    begin
    intro nd,
    cases l,
    exact list.nodup_nil,
    rw list.tail_cons,
    apply list.nodup_of_nodup_cons,
    exact nd,
    end

-- end lemmata

-- First we will need to define the types that characterize a (multi)digraph.

-- An arc connects a starting and ending vertex; this defines the Type for that.
-- in particular, this states that, given a Type (call it V), arcT V is a Type
-- defined as `V × V`, which is an ordered pair consisting of two elements of type V.
def arcT (V : Type) : Type := V × V
def arcT.mk {V : Type} (v1 v2 : V) : arcT V :=
    prod.mk v1 v2

-- Each digraph has a particular type of vertices, type of arcs, and consists of
-- the mapping φ from specific arcs to their starting and ending vertices.
structure digraph
    (V E : Type) : Type :=
    mk :: (φ : E → arcT V)

-- `arc G v1 v2` is an arc that goes from v1 to v2 in graph G.
-- V and E are implicit arguments (since they use {}): they can be filled in
-- once we know what the type of G is, since (G : digraph V E) mentions V and E.
def arc
    {V E : Type} (G : digraph V E)
    (v1 v2 : V) :=
        -- this is an edge paired with a proof that the edge connects
        -- the vertices mentioned in the type of the arc
        Σ'(e : E), G.φ e = arcT.mk v1 v2

-- The proposition that an arc exists, without specifying the arc itself.
def has_arc
    {V E : Type} (G : digraph V E)
    (v1 v2 : V) : Prop :=
        ∃ (e : E), G.φ e = arcT.mk v1 v2

-- Eliminate the existential has_arc with a non-dependent proof function taking an arc.
def has_arc.elim
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} {r : Prop} :
    has_arc G v1 v2 → (arc G v1 v2 → r) → r :=
        psigma_elim_exists

namespace digraph

-- Get the source of an edge E in a graph G
def source
    {V E : Type} (G : digraph V E)
    (e : E) : V := (G.φ e).1

-- Target of an arc
def target
    {V E : Type} (G : digraph V E)
    (e : E) : V := (G.φ e).2

-- An initial vertex has no edges leading to it in G
def is_initial
    {V E : Type} (G : digraph V E)
    (v : V) : Prop :=
        ¬∃ (e : E), target G e = v

-- A final vertex has no edges leading from it in G
def is_final
    {V E : Type} (G : digraph V E)
    (v : V) : Prop :=
        ¬∃ (e : E), source G e = v

-- Subtype generated by is_initial
-- (that is, a vertex with a proof that it is initial)
def initial
    {V E : Type} (G : digraph V E) :=
        { v : V // is_initial G v }

-- Subtype generated by is_final
def final
    {V E : Type} (G : digraph V E) :=
        { v : V // is_final G v }

-- A walk, as an inductive type, consists of arcs where each next arc leads
-- from the previous arc. This is encoded by matching the vertices at the type
-- level: only an arc from v1 to v2 and a walk from v2 to v3 can produce a walk
-- from v1 to v3.
-- Again, V and E can be figured out from an explicit G.
inductive walk
    {V E : Type} (G : digraph V E) :
    V → V → Type
    | empty {v : V} : walk v v
    | step {v1 v2 v3 : V} : arc G v1 v2 → walk v2 v3 → walk v1 v3

-- This begins a namespace; everything declared in this namespace will be accessed
-- with the prefix `walk.` outside of the namespace, like `walk.length`
namespace walk

-- The edges underlying a walk.
-- This is a function defined by taking some arguments (most notably a walk)
-- and returning a list of elements of type E.
-- Note that G is implicit: it's inferrable from the type of the walk given to edges
def edges
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} :
    walk G v1 v2 → list E :=
    -- this is tactic mode
    begin
    -- `intro` introduces the argument `w : walk G v1 v2`
    intro w,
    -- `induction` takes apart the two cases of `w` (`empty` and `step`)
    -- and adds an induction hypothesis for the nested walk in the `step` case
    induction w,
    -- for the first case, we want to produce an empty list
    -- `exact` just means that we are finishing the goal with a suitable term
    exact list.nil,
    -- for the second case, we `cons`truct a new list by adding the edge
    -- of the arc on the front to the front on the rest of the edges
    -- (note that w_ᾰ and w_ih are names automatically generated by `induction w`)
    exact list.cons w_ᾰ.1 w_ih,
    end

-- The vertices visited in a walk, including the start and end vertices
-- (which are already mentioned in the type).
def vertices
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} :
    walk G v1 v2 → list V :=
    begin
    -- similar story, but we start with v2 in the empty case
    intro w, induction w,
    exact list.cons v2 list.nil,
    -- and add v1 at each step
    exact list.cons w_v1 w_ih,
    end

-- The length of a walk, i.e. the number of arcs used in it, as a natural number.
def length
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} :
    walk G v1 v2 → ℕ :=
    begin
    intro w,
    induction w,
    exact 0,
    -- Note: nat.succ n = n+1, get used to it ;)
    exact nat.succ w_ih,
    end

-- This is our first lemma; it's like a definition but usually it contains a proof,
-- (in this case: a proof that the length of an empty walk is 0). Conceptually,
-- in type theory, there is no real difference: this is just another
-- dependently-typed function, taking variables V E G and v and returning a result.
@[simp] -- this attribute lets it get picked up by the `simp` tactic
lemma length_empty
    {V E : Type} {G : digraph V E}
    {v : V} :
    -- (empty G : walk G v v) is just a type annotation specifying v
    -- This could be written (empty _ : walk G v v), since G is
    -- inferrable by unification
    length (empty: walk G v v) = 0 :=
      by refl -- definitional equality holds here

@[simp]
lemma length_step
    {V E : Type} {G : digraph V E}
    {v1 v2 v3 : V}
    (a : arc G v1 v2)
    (w : walk G v2 v3) :
    length (step a w) = length w + 1 :=
      by refl

-- A walk from v1 to v2 can be concatenated with a walk from v2 to v3 by first
-- taking the arcs from the first walk, then taking the arcs from the second.
-- This is a binary function with two arguments, nothing else is new.
def concat
    {V E : Type} {G : digraph V E}
    {v1 v2 v3 : V} :
    walk G v1 v2 → walk G v2 v3 → walk G v1 v3 :=
    begin
    intros w1 w2,
    induction w1,
    exact w2,
    exact step w1_ᾰ (w1_ih w2),
    end

-- A proof of a fact that's obvious enough for the equation compiler to solve
@[simp]
lemma concat_empty_left
    {V E : Type} {G : digraph V E}
    {v1 v2 : V}
    (w : walk G v1 v2) :
    concat (empty) w = w :=
      by refl

-- Again, pretty obvious
lemma concat_step_left
    {V E : Type} {G : digraph V E}
    {v1 v2 v3 v4 : V}
    (a : arc G v1 v2)
    (w1 : walk G v2 v3)
    (w2 : walk G v3 v4) :
    concat (step a w1) w2 = step a (concat w1 w2) :=
      by refl

-- But this one needs to be solved by induction, since there's no special case
-- for an empty walk on the right (one must walk through all of the first walk).
@[simp]
lemma concat_empty_right
    {V E : Type} {G : digraph V E}
    {v1 v2 : V}
    (w : walk G v1 v2) :
    concat w (empty) = w :=
    begin
    -- luckily it is simple using induction
    induction w,
    refl,
    -- `rw` (or `rewrite`) is a tactic that changes the type of the goal
    -- given particular equalities; in this case, it finishes the goal too.
    rw [concat_step_left, w_ih],
    end

-- Concatenating walks adds their length.
lemma concat_length
    {V E : Type} {G : digraph V E}
    {v1 v2 v3 : V}
    (w1 : walk G v1 v2)
    (w2 : walk G v2 v3) :
    length (concat w1 w2) = length w1 + length w2 :=
    begin
    induction w1,
    -- this is easy enough for the tactic to solve by simplification,
    -- by using these facts (available with the [simp] attribute):
    -- 1. concat (empty G) w2 = w2
    -- 2. length (empty G) = 0
    simp,
    -- provide two additional theorems to help `simp` close the goal:
    simp [concat_step_left, w1_ih],
    rw add_assoc,
    rw add_assoc,
    rw add_comm 1 w2.length,
    end

-- Useful lemmata regarding walk.vertices
-- (still inside the walk namespace!)
namespace vertices

-- Takes an assumption that the walk is empty, making it easier to use
-- when the proof is not obviously `refl`. When it is obvious, use:
--     rw [walk.vertices.empty _ rfl],
@[simp]
def empty
    {V E : Type} {G : digraph V E}
    {v : V}
    (w : walk G v v) :
    (w = walk.empty) → walk.vertices w = [v] :=
        λ h, eq.substr h rfl

-- Takes an assumption that the walk is nonempty, making it easier to use
-- when the proof is not obviously `refl`. When it is obvious, use:
--     rw [walk.vertices.step _ _ _ rfl],
@[simp]
def step
    {V E : Type} {G : digraph V E}
    {v1 v2 v3 : V}
    (a : arc G v1 v2)
    (w : walk G v2 v3)
    (w' : walk G v1 v3) :
    (w' = walk.step a w) → walk.vertices w' = v1 :: walk.vertices w :=
        λ h, eq.substr h rfl

-- The list of vertices of a walk starts with the starting vertex of the walk.
def starts_with
    {V E : Type} {G : digraph V E}
    {v1 v2 : V}
    (w : walk G v1 v2) :
    walk.vertices w = v1 :: list.tail (walk.vertices w) :=
    begin
    cases w, refl, refl,
    end

-- The list of vertices follow concatenation ... except for the first vertex of
-- the second walk, which would be duplicated by just joining the verticces,
-- since it is the last entry in `walk.vertices w1` already.
def concat
    {V E : Type} {G : digraph V E}
    {v1 v2 v3 : V}
    (w1 : walk G v1 v2)
    (w2 : walk G v2 v3)
    (w3 : walk G v1 v3) :
    (w3 = walk.concat w1 w2) →
        walk.vertices w3 = walk.vertices w1 ++ list.tail (walk.vertices w2) :=
    begin
    intro h, rw h,
    induction w1,
    { simp, exact starts_with w2 },
    rw [concat_step_left w1_ᾰ w1_ᾰ_1 w2],
    -- simplify right side
    rw [step w1_ᾰ w1_ᾰ_1 _ rfl],
    -- simplify left side
    rw [step w1_ᾰ (concat w1_ᾰ_1 w2) _ rfl],
    -- pass through the cons, and apply induction hypothesis
    congr, apply w1_ih _ _ rfl,
    end

end vertices
end walk
-- close out the namespaces; back to the default namespace of this file

-- Back to types, a similar story regarding paths as walks:
-- A path is a walk with a proof that vertices are not repeated.
def path
    {V E : Type} (G : digraph V E) :
    V → V → Type :=
    λ v1 v2, { w : walk G v1 v2 // list.nodup (walk.vertices w) }

-- The proposition that a path between two vertices merely exists.
def has_path
    {V E : Type} (G : digraph V E) :
    V → V → Prop :=
    λ v1 v2, ∃ (w : walk G v1 v2), list.nodup (walk.vertices w)

-- Eliminate the existential has_path via a real path
def has_path.elim
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} {r : Prop} :
    has_path G v1 v2 → (path G v1 v2 → r) → r :=
        subtype_elim_exists

namespace path

-- An empty path is simple to generate; its list of 1 vertex obviously has no
-- duplicates.
def empty
    {V E : Type} (G : digraph V E)
    {v : V} : path G v v :=
    begin
    -- `apply` is sort of like `exact`, but it expects a function that requires more
    -- arguments to reach the proof goal.
    -- In particular, this starts to create a subtype with the value `empty`
    apply subtype.mk (walk.empty),
    -- but it requires a proof that there are no duplicates in its vertex list:
    simp [walk.vertices.empty, list.nodup_singleton],
    end

-- An arc between distinct vertices gives a path
def from_arc
    {V E : Type} (G : digraph V E)
    {v1 v2 : V} : (v1 ≠ v2) → arc G v1 v2 → path G v1 v2 :=
    begin
    intro h, intro a,
    -- `let` binds a local constant in a way that it can be referred to
    -- in other proof terms
    let w := walk.step a (walk.empty),
    apply subtype.mk w,
    -- `have` just provides a usuable constant whose definition can't be referred to
    have : walk.vertices w = [v1, v2], refl,
    rw this,
    -- `simp` helps make progress on the goal
    simp [list.nodup_singleton],
    -- the only thing missing is a proof that the vertices are distinct,
    -- which is true by assumption
    exact h -- or we could even use the `assumption` tactic
    end

@[reducible] -- [reducible] makes this definition more transparent
def length
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} :
    path G v1 v2 → ℕ :=
        λ p, walk.length p.1

-- This is a big topic: creating a path from a walk
-- Note that my proofs in this section are ugly, so feel free to skip them
-- (the high-level idea is easy enough to grasp; just know that it's
-- machine-verified ;D)
namespace from_walk

-- A helpful invariant: a walk with just a vertex removed preserves the property
-- of having no duplicates.
def preserves_nodup
    {V E : Type} {G : digraph V E}
    {v v1 v2 : V}
    (w : walk G v1 v2)
    (w' : walk G v v2) :=
        list.nodup (list.tail (walk.vertices w)) →
        list.nodup (list.tail (walk.vertices w'))

-- But it turns out that the desired walk being a subwalk is sufficient
def split_at
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} (w : walk G v1 v2) (v : V) :=
    Σ' (w1 : walk G v1 v) (w2 : walk G v v2),
        w = walk.concat w1 w2

-- This includes the other invariant we want to guarantee (that v does not
-- appear except as the first vertex of w2).
def split_at_without
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} (w : walk G v1 v2) (v : V) :=
    Σ' (w1 : walk G v1 v) (w2 : walk G v v2),
        (v ∉ list.tail (walk.vertices w2)) ∧
        w = walk.concat w1 w2

-- Weaken the latter to the former ...
-- Note: `a_of_b` is convention to indicate a function/lemma with a type like `b → a`
def split_at_of_split_at_without
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} {w : walk G v1 v2} {v : V} :
    split_at_without w v → split_at w v :=
    begin
    intro s, constructor, constructor, exact s.2.2.2
    end

-- And recover the invariant from it
lemma split_at.preserves_nodup
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} {w : walk G v1 v2} {v : V}
    (s : split_at w v) : preserves_nodup w s.2.1 :=
    begin
    cases s with w1 s, cases s with w2 p,
    intro nd, simp,
    rw [walk.vertices.concat _ _ _ p] at nd,
    rw [walk.vertices.starts_with _] at nd,
    simp at nd,
    rw list.nodup_append at nd,
    exact nd.2.1,
    end

def discard_vertex.split_at
    {V E : Type} [decidable_eq V] {G : digraph V E}
    (v : V) {v1 v2 : V} (w : walk G v1 v2) :
    psum (split_at_without w v) (v ∉ list.tail (walk.vertices w)) :=
    begin
    induction w with v0 v1 v2 v3 a w ih,
    right,
    simp [walk.vertices.empty _ rfl],
    simp [walk.vertices.step _ _ _ rfl],
    cases ih, left,
    apply psigma.mk (walk.step a ih.1),
    apply psigma.mk ih.2.1,
    apply and.intro ih.2.2.1,
    rw [walk.concat_step_left _ _ _],
    congr,
    exact ih.2.2.2,
    by_cases h : v = v2,
    left, rw h, rw h at ih,
    have : walk.concat (walk.step a (walk.empty)) w = walk.step a w,
    {
        simp [walk.concat_step_left _ _ _],
    },
    exact psigma.mk (walk.step a (walk.empty)) (psigma.mk w (and.intro ih this)),
    right,
    have : walk.vertices w = v2 :: list.tail (walk.vertices w),
        cases w, refl, refl,
    rw this, intro vin, cases vin,
    exact h vin, exact ih vin,
    end

-- Remove any occurrence of a vertex from a walk, by either returning a new walk
-- formed as a subset of the previous walk but starting from the vertex to be
-- removed (along with proofs that the vertex was removed, and that the new walk
-- contains no dupicates if the original did), OR a proof that the vertex
-- does not occur in the original walk.
--
-- This is obviously ugly, but encodes enough information to make from_walk work.
def discard_vertex
    {V E : Type} [decidable_eq V] {G : digraph V E}
    (v : V) {v1 v2 : V} (w : walk G v1 v2) :
    psum
        -- either a new walk
        (Σ' (w' : walk G v v2), -- from v to v2
            -- where v does not occur
            (v ∉ list.tail (walk.vertices w')) ∧
            -- and preserving the no duplicates property
            preserves_nodup w w')
        -- or a proof that the vertex does not occur in the original walk
        (v ∉ list.tail (walk.vertices w)) :=
    begin
    induction w with v0 v1 v2 v3 a w ih,
    right,
    simp [walk.vertices.empty _ rfl],
    simp [walk.vertices.step _ _ _ rfl],
    cases ih, left, apply psigma.mk ih.1, apply and.intro ih.2.1,
    intro ndaw, simp [walk.vertices.step _ _ _ rfl] at ndaw, apply ih.2.2,
    apply list.nodup_tail_of_nodup, exact ndaw,
    by_cases h : v = v2,
    left, rw h, rw h at ih,
    have : preserves_nodup (walk.step a w) w,
    {
        intro ndaw,
        simp [walk.vertices.step _ _ _ rfl] at ndaw,
        apply list.nodup_tail_of_nodup, exact ndaw,
    },
    exact psigma.mk w (and.intro ih this),
    right,
    have : walk.vertices w = v2 :: list.tail (walk.vertices w),
        cases w, refl, refl,
    rw this, intro vin, cases vin,
    exact h vin, exact ih vin,
    end

-- This can obviously be used to discard repeats of the first vertex of a walk.
-- But this is actually unused ...
def discard_vertex.beginning
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 : V} (w : walk G v1 v2) :
    Σ' (w' : walk G v1 v2),
        (v1 ∉ list.tail (walk.vertices w')) ∧
        preserves_nodup w w' :=
    begin
    have := discard_vertex v1 w,
    cases this, exact this,
    exact psigma.mk w (and.intro this id),
    end

-- Using induction on the walk, discard all the vertex repeats to generate a
-- path. This has the effect of removing all cycles in the walk.
def discard_vertex.all.explicit
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 : V} (w : walk G v1 v2) : path G v1 v2 :=
    begin
    -- Induction on a walk considers the base case (empty) and the step case
    induction w with v v1 v2 v3 a w ih,
    -- If the walk is empty, we already know how to generate an empty path; done.
    exact path.empty _,
    -- But if v1 = v2, we discard the arc, and just return the induction
    -- hypothesis (that is, the path generated from the tail), once we have
    -- rewritten v1 as v2.
    by_cases v1_v2 : (v1 = v2), rw v1_v2, exact ih,
    -- Just splits up the induction hypothesis into the walk and the proof.
    cases ih with ih_w ih_nodup,
    -- Now we discard the starting vertex from the induction hypothesis' walk
    have ih_w' := discard_vertex v1 ih_w,
    -- Consider the cases: a new walk, or the same walk
    cases ih_w', cases ih_w' with w' p,
    -- If we obtained a new walk, it is the walk we want to return
    apply subtype.mk w',
    -- Construct a proof that the walk has no duplicates
    rw [walk.vertices.starts_with, list.nodup_cons], constructor,
    -- from the fact that v does not occur in the rest of the vertices
    exact p.1,
    -- and the fact that the ih had no duplicates, so the tail of this has none
    exact (p.2 (list.nodup_tail_of_nodup ih_nodup)),
    -- Otherwise, we should return the walk consisting of this arc and the ih walk
    apply subtype.mk (walk.step a ih_w),
    -- Do some rewrites of the goal ...
    rw [walk.vertices.step _ _ _ rfl, list.nodup_cons], constructor,
    rw [walk.vertices.starts_with, list.mem_cons_iff],
    -- We know that v1 is not the second vertex v2, nor is it in ih_w
    apply not_or v1_v2 ih_w',
    -- And the rest of the ih already had no duplicates, by induction
    exact ih_nodup,
    end

-- This contains the above algorithm but also produces the proof that either
-- the result is the same, or the walk/graph contained a cycle.
--
-- This can be used to prove the equivalence of walks and paths in acyclic
-- digraphs.
def discard_vertex.all.acyc_prf
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 : V} (w : walk G v1 v2) :
        Σ' (p : path G v1 v2),
            p.1 = w ∨ ∃(v : V) (c : walk G v v), c ≠ walk.empty :=
    begin
    induction w with v v1 v2 v3 a w ih,
    exact psigma.mk (path.empty _) (or.inl rfl),
    by_cases v1_v2 : (v1 = v2),
    apply psigma.mk, right, tactic.swap,
    rw v1_v2, exact ih.1,
    apply exists.intro v2,
    rw v1_v2 at a,
    apply exists.intro (walk.step a (walk.empty)),
    exact λ h, walk.no_confusion h,
    cases ih with ih prf, cases ih with ih_w ih_nodup,
    have ih_w' := discard_vertex.split_at v1 ih_w,
    cases ih_w',
    have := split_at.preserves_nodup (split_at_of_split_at_without ih_w'),
    cases ih_w' with w1 ih_w', cases ih_w' with w2 p,
    apply psigma.mk (subtype.mk w2
        begin
        rw [walk.vertices.starts_with, list.nodup_cons], constructor,
        exact p.1,
        exact (this (list.nodup_tail_of_nodup ih_nodup)),
        end : path G v1 v3),
    right, apply exists.intro v1,
    apply exists.intro (walk.step a w1),
    exact λ h, walk.no_confusion h,
    apply psigma.mk (subtype.mk (walk.step a ih_w)
        begin
        rw [walk.vertices.step _ _ _ rfl],
        rw [list.nodup_cons], constructor,
        rw [walk.vertices.starts_with],
        rw list.mem_cons_iff,
        apply not_or v1_v2 ih_w',
        exact ih_nodup,
        end : path G v1 v3),
    cases prf,
    left,
    simp at prf,
    simp [prf],
    right,
    exact prf,
    end

-- This defeq will be important
@[reducible]
def discard_vertex.all
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 : V} (w : walk G v1 v2) : path G v1 v2 :=
    (discard_vertex.all.acyc_prf w).1

end from_walk

-- This just references the version inside the from_walk namespace
@[reducible]
def from_walk
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 : V} :
    walk G v1 v2 → path G v1 v2 := from_walk.discard_vertex.all

-- This concatenates the underlying paths then removes cycles to generate
-- the new path.
def concat
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 v3 : V}
    (p1 : path G v1 v2)
    (p2 : path G v2 v3) :
    path G v1 v3 := from_walk (walk.concat p1.1 p2.1)

-- A maximal path is a path going to a final vertex.
def maximal
    {V E : Type} (G : digraph V E)
    (v1 v2 : V) := pprod (path G v1 v2) (is_final G v2)
                    -- (pprod stores a piece of data and a separate proof)

-- Proposition that one exists.
def has_maximal
    {V E : Type} (G : digraph V E)
    (v1 v2 : V) := (has_path G v1 v2) ∧ (is_final G v2) -- regular conjunction

-- Eliminate it following the usual pattern
def has_maximal.elim
    {V E : Type} {G : digraph V E}
    {v1 v2 : V} {r : Prop} :
    has_maximal G v1 v2 → (maximal G v1 v2 → r) → r :=
        λ h f, has_path.elim h.1 (λ p, f (pprod.mk p h.2))

-- Hopefully this makes sense now by just looking at the types!
def maximal.concat
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 v3 : V}
    (p1 : path G v1 v2)
    (p2 : path.maximal G v2 v3) :
    path.maximal G v1 v3 :=
    begin
    constructor,
    exact path.concat p1 p2.1,
    exact p2.2,
    end

def has_maximal.concat
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 v3 : V}
    (p1 : path G v1 v2)
    (p2 : path.has_maximal G v2 v3) :
    path.has_maximal G v1 v3 :=
    flip and.intro p2.2
    begin
    apply exists.elim p2.1, intro w, intro nodup,
    exact subtype.exists_of_subtype (path.concat p1 (subtype.mk w nodup)),
    end

-- If the walk underlying a path is nonempty, produce the path corresponding
-- to its tail.
def vertices.step_back
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 v3 : V}
    (a : arc G v1 v2)
    (w : walk G v2 v3)
    (p : path G v1 v3) :
    (p.1 = walk.step a w) → path G v2 v3 :=
    begin
    intro h, cases p, simp at h,
    apply subtype.mk w,
    rw [walk.vertices.step _ _ _ h] at p_property,
    exact list.nodup_of_nodup_cons p_property,
    end

end path

-- One encoding (fairly direct and easy to use) of the property of an acyclic
-- graph: all walks from a vertex to itself are empty.
def is_acyclic
    {V E : Type} (G : digraph V E) :=
        ∀ (v : V) (w : walk G v v), w = walk.empty

-- Subtype generated from that (unused).
def acyclic
    {V E : Type} :=
        { G : digraph V E // is_acyclic G }

-- It turns out that in acyclic graphs, from_walk just elaborates the same walk
-- with a proof term.
lemma is_acyclic.from_walk
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 : V}
    (acyc : is_acyclic G)
    (w : walk G v1 v2) :
    (path.from_walk w).val = w :=
    begin
    let fw := path.from_walk.discard_vertex.all.acyc_prf w,
    have : path.from_walk w = fw.1, refl, rw this,
    cases h : fw with p prf,
    simp,
    cases prf,
    exact prf,
    exfalso,
    apply exists.elim prf, intro v, intro prf',
    apply exists.elim prf', intro c, intro prf'',
    exact prf'' (acyc v c)
    end

-- Thus paths and walks are equivalent in acyclic digraphs.
def path.equiv_walk
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 : V} :
    is_acyclic G →
    walk G v1 v2 ≃ path G v1 v2 := λ acyc,
    -- this is an equivalence a ≃ b: a pair of functions a → b and b → a,
    -- with proofs that they are inverses of each other
    equiv.mk path.from_walk subtype.val
        (is_acyclic.from_walk acyc)
        (λ p, subtype.eq (is_acyclic.from_walk acyc p.val))

-- Since the cycle elimination algorithm does nothing in an acyclic graph,
-- lengths are preserved through concatenation
lemma path.acyclic_concat_length
    {V E : Type} [decidable_eq V] {G : digraph V E}
    {v1 v2 v3 : V}
    (p1 : path G v1 v2)
    (p2 : path G v2 v3) :
    is_acyclic G →
    path.length (path.concat p1 p2) = path.length p1 + path.length p2 :=
    begin
    intro acyc,
    show walk.length (path.concat p1 p2).1 = walk.length p1.1 + walk.length p2.1,
    show walk.length (path.from_walk (walk.concat p1.1 p2.1)).1
       = walk.length p1.1 + walk.length p2.1,
    rw [is_acyclic.from_walk acyc _],
    exact walk.concat_length _ _,
    end

-- Okay, done with types! On to the main course:

-- The so-called “no-watershed condition”: for any two vertices with arcs
-- from(!) a common vertex, there is another vertex that has paths from
-- both of those. (Obviously true if {u,v,w} are not distinct.)
-- See section 0.2 in http://www-users.math.umn.edu/~dgrinber/comb2/mt3.pdf
def no_watershed_condition
    {V E : Type} (G : digraph V E) : Prop :=
    Π (u v w : V),
        arc G u v → arc G u w →
        ∃ (t : V), has_path G v t ∧ has_path G w t

-- Having the no-watershed condition in an acyclic graph produces the result
-- that each vertex has a unique sink; that is, a vertex with a maximal path
-- from the other vertex.
namespace unique_sink

-- Inside a namespace/section, we can use the following commands to declare variables
-- used in the definitions/lemmata for this section:
-- implicit and explicit arguments
variables {V E : Type} (G : digraph V E)
variables acyc : is_acyclic G
-- and typeclass arguments! these are variables of a special type that have a
-- canonical value
-- In particular:
-- decidable_eq V gives a function Π(v1 v2 : V), (v1 = v2) ∨ (v1 ≠ v2)
-- that decides whether two vertices are equal, giving a proof either way
-- fintype V asserts that V has finitely many inhabitants, by giving a list
-- of them all (actually a finite set `finset`), and a proof that every
-- element occurs in it: ∀ v : V, v ∈ univ V
variables [decidable_eq V] [decidable_eq E] [fintype V] [fintype E]

-- Now that we have G as a fixed local variable, we can use it in notation!
-- who doesn't love syntactic sugar?!?!? :D
local infix `⟶`:50 := arc G
local infix `~⟶`:50 := walk G -- unused
local infix `*⟶`:50 := path G
local infix `×⟶`:50 := path.maximal G
-- and their propositional equivalents
local infix `⟼`:50 := has_arc G
local infix `*⟼`:50 := has_path G
local infix `×⟼`:50 := path.has_maximal G

-- In finite acyclic graphs, each vertex will have a longest path;
-- if `bounded_by p n` is provided, then the longest path from p is at most n steps.
def bounded_by (p : V) (n : ℕ) := ∀ (q : V) (w : p *⟶ q), path.length w ≤ n

-- This is the proposition used for induction. It limits the results to
-- only pertain to vertices p whose paths away from them have length at most n.
def P (n : ℕ) :=
    ∀ (p : V),
        bounded_by G p n →
        ∃! (q : V), p ×⟼ q

-- Helper: These are logically equivalent via two existing lemmate...
lemma eq_zero_iff_le_zero {n : nat} : n ≤ 0 ↔ n = 0 :=
    iff.intro nat.eq_zero_of_le_zero nat.le_of_eq

-- A walk of length 0 obviously connects the same two vertices.
lemma length0 {v1 v2 : V} (w : v1 ~⟶ v2) :
    walk.length w = 0 → v1 = v2 :=
    begin
    intro h,
    -- obviously the `empty` case is trivial:
    cases w, refl,
    -- but the `step` case is absurd!
    rw [walk.length_step] at h,
    exact absurd h (nat.succ_ne_zero (walk.length w_ᾰ_1)),
    end

-- Two maximal paths from the same vertex cannot have one be empty and the other
-- be nonempty.
lemma not_diff_emptiness
    {p q1 q2 : V}
    (w1 : p ×⟶ q1)
    (w2 : p ×⟶ q2) :
    ¬(path.length w1.1 = 0 ∧ path.length w2.1 > 0) :=
    begin
    intro h,
    have pq1 := length0 G w1.1.1 h.1,
    have q1_final := w1.2,
    rw [← pq1] at q1_final,
    apply q1_final,
    let w := w2.1.1,
    cases hw : w,
    apply flip absurd (ne_of_gt h.2),
    show walk.length w = 0,
    rw hw, exact walk.length_empty,
    apply exists.intro ᾰ.1,
    have x : (arcT.mk p v2).1 = p, refl,
    rw [← ᾰ.2] at x,
    exact x,
    end

-- ... basically the same as above, but more explicit.
lemma same_emptiness
    {p q1 q2 : V}
    (w1 : p ×⟶ q1)
    (w2 : p ×⟶ q2) :
    (path.length w1.1 = 0 ∧ path.length w2.1 = 0) ∨
    (path.length w1.1 > 0 ∧ path.length w2.1 > 0) :=
    begin
    cases h1 : path.length w1.1,
    left, constructor, refl,
    cases h2 : path.length w2.1, refl,
    apply flip absurd (not_diff_emptiness G w1 w2),
    constructor, exact h1,
    have := nat.zero_lt_succ n,
    rw [← h2] at this,
    exact this,
    right, constructor, exact nat.zero_lt_succ n,
    cases h2 : path.length w2.1,
    apply flip absurd (not_diff_emptiness G w2 w1),
    constructor, exact h2,
    have := nat.zero_lt_succ n,
    rw [← h1] at this,
    exact this,
    exact nat.zero_lt_succ n_1,
    end

-- A proof that each path has finite length, bounded above by the number of vertices
lemma finite {p q : V} (w : p *⟶ q) : path.length w + 1 ≤ fintype.card V :=
    begin
    cases w with w nodup,
    -- this should really be a separate lemma, but it's easy enough to prove inline...
    have : walk.length w + 1 = list.length (walk.vertices w),
    {
        induction w,
        refl, simp [walk.vertices.step _ _ _ rfl],
        apply w_ih,
        rw [walk.vertices.step _ _ _ rfl] at nodup,
        exact list.nodup_of_nodup_cons nodup,
    },
    rw this,
    -- now we don't need the fact that it is a list of vertices anymore
    -- so replace it with a generic `l : list V` in the hypothesis and goal:
    generalize_hyp h : walk.vertices w = l at nodup, rw h,
    -- make a finite set from the list
    let fs : finset V := finset.mk (quotient.mk l) nodup,
    -- with the same size
    have : list.length l = finset.card fs :=
    by symmetry; apply quot.lift_beta list.length multiset.card._proof_1,
    rw this,
    -- it must be smaller or the same size, since it is a subset
    exact finset.card_le_of_subset (finset.subset_univ _),
    end

-- A vertex is either final or it has an arc leading from it to some other vertex.
-- Relies on [fintype E]
def any_arc_from (p : V) :
    (∃ (v : V), p ⟼ v) ∨ is_final G p :=
    begin
    let elems : finset E := finset.univ,
    -- Prove that these are equivalent
    -- instead of proving each direction separately, we use bijections at each step
    have : (p ∈ multiset.map (source G) elems.val) ↔ (∃(e : E), source G e = p),
        symmetry,
        rw multiset.mem_map,
        apply exists_congr,
        intro e,
        symmetry,
        apply and_iff_right,
        exact finset.mem_univ e,
    -- this is a decidable proposition, so we can determine whether it is true or false
    by_cases h : p ∈ multiset.map (source G) elems.val,
    {
        rw this at h,
        left,
        apply exists.elim h, intro e, intro he,
        apply exists.intro (target G e),
        apply exists.intro e,
        apply prod.eq_iff_fst_eq_snd_eq.2, constructor,
        show (G.φ e).1 = p, exact he,
        show (G.φ e).2 = target G e, refl,
    },
    {
        rw this at h,
        right, exact h,
    },
    end

-- tactic mode doesn't know to include this variable
-- we will use it in the remaining proofs
include acyc

-- If all paths leading out of a vertex have length 0, it must be a sink
def is_final_of_bounded_by_zero (v : V) :
    bounded_by G v 0 → is_final G v :=
    begin
    intros len,
    have := any_arc_from G v,
    cases this,
    {
        exfalso,
        apply exists.elim this, intros v1 ha,
        apply has_arc.elim ha, intro a,
        let p : v *⟶ v1 := path.from_walk (walk.step a (walk.empty)),
        have len0 := len _ p,
        rw [eq_zero_iff_le_zero] at len0,
        suffices : path.length p = 1, cc,
        have : p.1 = walk.step a (walk.empty),
            from is_acyclic.from_walk acyc _,
        unfold path.length, rw this, refl
    },
    exact this,
    end

-- Helper for induction: giving a path from v1 to v2 with length no less
-- than m and the fact that all paths from v1 are at most length n+m, means
-- that a path from v2 to v3 must have length at most n.
lemma reduce_length
    {v1 v2 v3 : V}
    {n m : ℕ}
    (w : v1 *⟶ v2)
    (p : v2 *⟶ v3)
    (lw : path.length w ≥ m)
    (mh : bounded_by G v1 (n+m)) :
    path.length p ≤ n :=
    begin
    let wp : v1 *⟶ v3 := path.concat w p,
    have lwp : path.length wp = path.length w + path.length p,
        from path.acyclic_concat_length w p acyc,
    -- rewrite lw at lwp,
    apply @nat.le_of_add_le_add_left (path.length w) _ _,
    rw [← lwp, add_comm],
    transitivity,
    apply mh v3,
    exact nat.add_le_add_left lw _,
    end

-- All vertices have a sink.
-- This is a smaller proof following the style of the larger proof.
-- We prove it by induction for all vertices that are bounded by n,
-- then we pick a sufficiently large n to cover all vertices.
lemma find_sink.bounded (n : ℕ) (v1 : V) :
    bounded_by G v1 n →
    ∃ (s : V), v1 ×⟼ s :=
    begin
    intros len,
    induction n with n ih generalizing v1,
    {
        apply exists.intro v1,
        apply and.intro (subtype.exists_of_subtype (path.empty G)),
        apply is_final_of_bounded_by_zero, assumption, assumption,
    },
    have := any_arc_from G v1,
    cases this,
    {
        apply exists.elim this, intros v2 ha,
        apply has_arc.elim ha, intro a,
        let p : v1 *⟶ v2 := path.from_walk (walk.step a (walk.empty)),
        have := ih v2
            begin
            have : path.length p = 1,
                have : p.1 = walk.step a (walk.empty),
                    from is_acyclic.from_walk acyc _,
                unfold path.length, rw this, refl,
            intros v' p',
            apply reduce_length G acyc p,
            exact ge_of_eq this,
            exact len,
            end,
        apply exists.elim this, intros s hm,
        apply exists.intro s,
        exact path.has_maximal.concat p hm
    },
    {
        apply exists.intro v1,
        apply and.intro (subtype.exists_of_subtype (path.empty G)),
        assumption,
    },
    end

-- Using `finite`, we pick a sufficient n to bound all vertices
lemma find_sink
    (v1 : V) :
    ∃ (s : V), v1 ×⟼ s :=
        find_sink.bounded G acyc _ v1
            begin
            unfold bounded_by, intros,
            rw ← nat.pred_succ (path.length w),
            apply nat.pred_le_pred,
            apply unique_sink.finite G
            end

-- Final vertices are their own sink
lemma P_final (p : V) : is_final G p → ∃!(q : V), p ×⟼ q :=
    begin
    intro final, apply exists_unique.intro p,
    constructor, exact subtype.exists_of_subtype (path.empty G), exact final,
    intro sink, intro has_max, apply subtype_elim_exists has_max.1,
    intro p, cases p, cases p_val, refl, exfalso,
    apply final,
    apply exists.intro p_val_ᾰ.1,
    show (G.φ p_val_ᾰ.1).1 = p,
    rw p_val_ᾰ.2, refl
    end

-- The base case, basically applies only to sinks, which are their own
-- sink, obviously.
lemma P0 : P G 0 :=
    λ p len, P_final _ acyc p (is_final_of_bounded_by_zero _ acyc p len)

-- The whole proof together.
--
-- Big picture idea:
-- For any vertex p with bounded_by G p n, try to find an arc leading out of it, call
-- its target v (≠ p). The unique sink can be obtained by applying induction to v.
-- But to establish that it is also unique for p, we take any otherSink
-- with a maximal path from p, take the first new vertex visited by that path v2
-- and we can apply the watershed condition to an arc p v and an arc p v2 to get t with
-- a path v t and a path v2 t. But by using this, the sinks from v, t, and v2 must
-- all be the same since we can extend the maximal path from t to be from v or v2.
-- This is essentially the statement that connected vertices share the same sink...
-- (Obviously the computer requires more details to formalize this and accept
-- it as rigorous, but they are explained below.)
theorem Pn : no_watershed_condition G → ∀ (n : ℕ), P G n :=
    begin
    -- introduce the watershed condition as a variable in scope
    intro watershed,
    -- this is the variable for induction, named n' since n will be in scope
    intro n,
    -- regular induction on natural numbers (just a special case of induction in DTT)
    induction n with n ih,
    -- base case, already proved as P0 above
    exact P0 G acyc,
    -- this is the vertex of interest
    intro p,
    -- and the proof that maximal paths from p have length at most n+1
    intro len,
    -- try to obtain an arc from p
    have aa := any_arc_from G p,
    -- this splits it up into the two cases, replacing aa with the result of each case
    -- (what follows is mostly the proof of the first case, the second takes one line)
    cases aa,
    apply exists.elim aa,
    -- obtain the vertex it goes to, and the proof that there is an arc
    intro v, assume ha : p ⟼ v,
    -- obtain some actual arc from p to v
    apply has_arc.elim ha, assume a : p ⟶ v,
    -- a funny proof by contradiction that p ≠ v since it is in an acyclic graph
    -- TODO: factor this out
    by_cases (p = v),
    {
        let a' : p ⟶ v := a,
        rw h at a',
        have := acyc _ (walk.step a' (walk.empty)),
        exfalso,
        exact walk.no_confusion this,
    },
    -- using that we can make a path from the arc ...
    let start : p *⟶ v := path.from_arc G h a,
    -- ... of length 1 (duh!)
    have len1 : path.length start = 1, refl,
    -- Now we can apply the induction hypothesis onto v, since `start`
    -- guarantees that the length will go down by 1.
    have exu := ih v
        begin
        intro v', intro p',
        apply reduce_length G acyc start p' (ge_of_eq len1) len,
        end,
    -- Now we unpack the existentials ...
    apply exists_unique.elim exu, simp,
    -- ... to obtain the sink, the existence of a maximal path from v to that
    -- sink, and the proof that that sink is unique
    intro sink, intro has_maxPathToSink, intro uniq,
    -- so we know that this is the sink we want, just need to prove it has a
    -- maximal path ...
    apply exists_unique.intro sink,
    apply subtype_elim_exists has_maxPathToSink.1,
    assume pathToSink : v *⟶ sink,
    constructor,
    apply subtype.exists_of_subtype,
    apply path.concat start pathToSink,
    exact has_maxPathToSink.2,
    -- ... and that it is unique. Oh boy.
    -- Given otherSink and a max path from p to otherSink, prove that they are
    -- the same sink.
    intro otherSink, intro has_maxPathToOtherSink,
    show otherSink = sink,
    apply path.has_maximal.elim has_maxPathToOtherSink,
    assume maxPathToOtherSink : p ×⟶ otherSink,
    -- Argue that the maximal path is nonempty.
    cases hp : maxPathToOtherSink.1.1,
    {
        exfalso, apply maxPathToOtherSink.2, apply exists.intro a.1,
        show (G.φ a.1).1 = p,
        exact (prod.eq_iff_fst_eq_snd_eq.1 (a.2)).1,
    },
    -- Now we have hp : (maxPathToOtherSink.fst).val = walk.step a_1 a_2
    -- so ᾰ is an arc from p to some v2
    -- Apply the watershed condition with a : arc G p v, ᾰ : arc G p v2
    have water1 := watershed p v v2 a ᾰ,
    -- so there is some t with paths from v to t and from v2 to t
    apply exists.elim water1, intro t, simp,
    intro has_vt, intro has_v2t,
    apply subtype_elim_exists has_vt, intro vt,
    apply subtype_elim_exists has_v2t, intro v2t,
    -- now we have another path like starting, but from p to t, via v.
    let startt : p *⟶ t := path.concat start vt,
    -- Induction again!
    have exu2 := ih t
        begin
        intro v', intro p',
        -- startt has length at least 1, since start has length 1, and
        -- vt may have length greater than 1, and since it is acyclic.
        have len_ge1 : path.length startt ≥ 1,
            have : path.length startt = path.length start + path.length vt,
                from path.acyclic_concat_length start vt acyc,
            rw len1 at this,
            transitivity,
            exact le_of_eq (eq.symm this),
            rw [add_comm],
            exact nat.succ_le_succ (nat.zero_le (path.length vt)),
        apply reduce_length G acyc startt p' len_ge1 len,
        end,
    apply exists_unique.elim exu2, simp,
    -- Oh here is anotherSink! the unique sink from t
    intro anotherSink, intro has_maxPathToAnotherSink, intro uniq2,
    -- but anotherSink = sink, since any maxpath can be extended along vt
    have := uniq _ (path.has_maximal.concat vt has_maxPathToAnotherSink),
    -- again argue that an arc connects distinct vertices
    by_cases (p = v2),
    {
        let a' : p ⟶ v2 := ᾰ,
        rw h at a',
        have := acyc _ (walk.step a' (walk.empty)),
        exfalso, exact walk.no_confusion this,
    },
    -- So there's a path from p to v2 just using the arc ᾰ.
    let startv2 : p *⟶ v2 := path.from_arc G h ᾰ,
    -- Induction yet again! last time I promise
    have exuv2 := ih v2
        begin
        intro v', intro p',
        apply reduce_length G acyc startv2 p',
        exact ge_of_eq (rfl : path.length startv2 = 1),
        exact len,
        end,
    apply exists_unique.elim exuv2, simp,
    -- finalSink is the unique sink from v2
    intro finalSink, intro has_maxPathToFinalSink, intro uniqv2,
    -- but finalSink = otherSink, due to the maxpath a_2 from v2 to otherSink
    have := uniqv2 otherSink
        begin
        -- construct the maxpath
        constructor,
        -- we can demonstrate the exact path, but we just need its existence,
        apply subtype.exists_of_subtype,
        -- hp : (maxPathToOtherSink.fst).val = walk.step a_1 a_2
        -- means that just the walk a_2 creates a path too
        exact path.vertices.step_back _ _ maxPathToOtherSink.1 hp,
        -- and is maximal since otherSink is still final
        exact maxPathToOtherSink.2,
        end,
    -- and finalSink = anotherSink, by extending maxpaths along v2t
    have := uniqv2 anotherSink
                (path.has_maximal.concat v2t has_maxPathToAnotherSink),
    -- so the congruence closure calculates that otherSink = sink via
    -- the equalities in scope
    cc,
    -- Oh yeah, and if aa had no arcs, then its a final vertex and we're done.
    exact P_final G acyc p aa,
    end

end unique_sink

-- It turns out that we can pick a sufficient n such that Pn holds for all p
theorem unique_sink
    {V E : Type} {G : digraph V E}
    [decidable_eq V] [decidable_eq E] [fintype V] [fintype E] :
    is_acyclic G → no_watershed_condition G →
    ∀ (p : V), ∃! (q : V), path.has_maximal G p q :=
        λ acyc watershed p, unique_sink.Pn G acyc watershed _ p
            begin
            unfold unique_sink.bounded_by, intros,
            rw ← nat.pred_succ (path.length w),
            apply nat.pred_le_pred,
            apply unique_sink.finite G
            end

end digraph


open Nat

inductive BV : Nat → Type
| nil  : BV 0
| cons : ∀ (n) (hd : Bool) (tl : BV n), BV (succ n)

open BV

variable (f : Bool → Bool → Bool)

def map2 : {n : Nat} →  BV n → BV n → BV n
| .(0), nil, nil             => nil
| .(n+1), cons n b1 v1, cons .(n) b2 v2 => cons n (f b1 b2) (map2 v1 v2)

theorem ex1 : map2 f nil nil = nil :=
rfl

theorem ex2 (n : Nat) (b1 b2 : Bool) (v1 v2 : BV n) : map2 f (cons n b1 v1) (cons n b2 v2) = cons n (f b1 b2) (map2 f v1 v2) :=
rfl

#print map2

def map2' : {n : Nat} →  BV n → BV n → BV n
| _, nil,          nil          => nil
| _, cons _ b1 v1, cons _ b2 v2 => cons _ (f b1 b2) (map2' v1 v2)

theorem ex3 : map2' f nil nil = nil :=
rfl

theorem ex4 (n : Nat) (b1 b2 : Bool) (v1 v2 : BV n) : map2' f (cons n b1 v1) (cons n b2 v2) = cons n (f b1 b2) (map2' f v1 v2) :=
rfl


import algebra.order.group.with_top
import analysis.special_functions.pow
import data.finset.basic
import data.nat.modeq
import data.nat.prime
import data.nat.prime_norm_num
import data.rat.basic
import number_theory.padics.padic_integers
import tactic

open finset nat int
open_locale nat classical

variables {p : ℕ} [hp : fact (nat.prime p)]
include hp

namespace padic

@[simp] lemma valuation_neg_one : (-1 : ℚ_[p]).valuation = 0 :=
begin
  -- We transfer to `padic.add_valuation`, which is an actual valuation and use their results
  have h : padic.add_valuation (-1 : ℚ_[p]) = padic.add_valuation (1 : ℚ_[p]),
  { exact add_valuation.map_neg padic.add_valuation (1 : ℚ_[p]), },
  rw [padic.add_valuation.apply, padic.add_valuation.apply] at h,
  simp only [with_top.coe_eq_coe.1 h, padic.valuation_one],
  simp only [ne.def, one_ne_zero, not_false_iff],
  simp only [ne.def, neg_eq_zero, one_ne_zero, not_false_iff],
end

@[simp] lemma valuation_neg {n : ℚ_[p]} : (-n).valuation = n.valuation :=
begin
  by_cases h : n = 0,
  { rw [h, neg_zero], },
  { rw [← mul_neg_one, padic.valuation_map_mul h (neg_ne_zero.2 one_ne_zero), valuation_neg_one,
        add_zero], },
end

end padic

namespace padic_int

theorem coe_inj {n : ℤ_[p]} (h : n ≠ 0) : (n : ℚ_[p]) ≠ 0 := begin
  cases n,
  simp only [subtype.coe_mk, ne.def],
  intro h',
  simp_rw [h', padic_int.mk_zero] at h,
  exact h (eq.refl 0),
end

theorem image {n : ℤ_[p]} : n ≠ 0 → (∃ k : ℕ, ‖n‖ = (↑p ^ -(k : ℤ))) :=
begin
  intro hn,
  cases @padic_norm_e.image' p _ ↑n (coe_inj hn) with k hk,
  have k_nonneg : 0 ≤ k,
  { sorry, },
  use k.to_nat,
  rw [to_nat_of_nonneg k_nonneg, norm_def, ← rat.cast_coe_nat, ← rat.cast_zpow, ← hk,
      padic_norm_e.is_norm],
end

@[simp] theorem valuation_neg {n : ℤ_[p]} : (-n).valuation = n.valuation := padic.valuation_neg

theorem valuation_map_add {m n : ℤ_[p]} (hmn : m + n ≠ 0) :
min m.valuation n.valuation ≤ (m + n).valuation :=
begin
  apply padic.valuation_map_add,
  rwa [← coe_add, ne.def, coe_eq_zero],
end

theorem norm_add_eq_max_of_ne' {q r : ℤ_[p]} (h : ‖q‖ < ‖r‖) : ‖q + r‖ = ‖r‖ :=
begin
rw [norm_add_eq_max_of_ne (ne_of_lt h), max_eq_right_iff.2 (le_of_lt h)],
end

theorem valuation_p_pow_mul_add (n : ℕ) (c r : ℤ_[p]) (hn : 0 < n) (hc : c ≠ 0) (hr : r ≠ 0)
(h : r.valuation < n) : (↑p ^ n * c + r).valuation = r.valuation :=
begin
  let hp : nat.prime p := fact_iff.1 hp,
  suffices : ‖↑p ^ n * c + r‖ = ‖r‖,
  { rwa [norm_eq_pow_val, norm_eq_pow_val hr, zpow_inj, neg_inj] at this;
    simp only [nat.cast_pos, ne.def, zpow_neg, inv_inj] at *,
    -- Just fixing all the ... ≠ 0 requirements
    { exact prime.pos hp, },
    { by_contradiction hp',
      rw [← nat.cast_one, nat.cast_inj] at hp',
      exact nat.prime.ne_one hp hp', },
    { by_contradiction,
      rw add_eq_zero_iff_eq_neg at h,
      have h' : ↑n + c.valuation = r.valuation,
      { rwa [← valuation_p_pow_mul, ← @valuation_neg p _ r, h], },
      have : ↑n ≤ r.valuation,
      { rw [← h'], exact int.le_add_of_nonneg_right (valuation_nonneg _), },
      linarith, }, },
  apply norm_add_eq_max_of_ne',
  cases @image p _ c hc with k hk,
  rw [norm_mul, norm_p_pow, norm_eq_pow_val hr, hk, ← zpow_add'],
  { sorry, },
  { left, rw [ne.def, nat.cast_eq_zero], exact nat.prime.ne_zero hp, },
end

end padic_int

-- Just proving Wang's counterexamples to Grunwald's wrong result
-- Main tool is to use p-adic valuations to disprove results

-- 16 is not an 8th power over the integers
lemma part1 : ¬∃ n : ℤ, n ^ 8 = 16 :=
begin
  suffices : ¬∃ n : ℕ, n ^ 8 = 16,
  { contrapose! this,
    cases this with n h,
    exact ⟨n.nat_abs, by { zify, simpa only [pow_abs, h] }⟩, },
  by_contradiction,
  cases h with n hn,
  by_cases hn' : n = 0,
  { rw hn' at hn, linarith, },
  have h : padic_val_nat 2 (n ^ 8) = padic_val_nat 2 16,
  { rw hn, },
  rw [show 16 = 2 ^ 4, by norm_num,
      @padic_val_nat.pow _ _ nat.fact_prime_two 4 _, padic_val_nat.self] at h;
    try { simp, },
  { rw padic_val_nat.pow at h,
    have h' : 8 ∣ 8 * padic_val_nat 2 n,
    { exact dvd_mul_right _ _, },
    norm_num [h] at h',
    exact hn', },
end

-- 16 is not an 8th power over Z₂
lemma part2 : ¬∃ n : ℤ_[2], n ^ 8 = 16 :=
begin
  push_neg,
  intro n,
  by_contradiction,
  have : (n ^ 8).valuation = (2 ^ 4 : ℤ_[2]).valuation,
  { norm_num, rw h, },

end


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import algebra.algebra.subalgebra
import algebra.monoid_algebra.basic

/-!
# Free Algebras

Given a commutative semiring `R`, and a type `X`, we construct the free unital, associative
`R`-algebra on `X`.

## Notation

1. `free_algebra R X` is the free algebra itself. It is endowed with an `R`-algebra structure.
2. `free_algebra.ι R` is the function `X → free_algebra R X`.
3. Given a function `f : X → A` to an R-algebra `A`, `lift R f` is the lift of `f` to an
  `R`-algebra morphism `free_algebra R X → A`.

## Theorems

1. `ι_comp_lift` states that the composition `(lift R f) ∘ (ι R)` is identical to `f`.
2. `lift_unique` states that whenever an R-algebra morphism `g : free_algebra R X → A` is
  given whose composition with `ι R` is `f`, then one has `g = lift R f`.
3. `hom_ext` is a variant of `lift_unique` in the form of an extensionality theorem.
4. `lift_comp_ι` is a combination of `ι_comp_lift` and `lift_unique`. It states that the lift
  of the composition of an algebra morphism with `ι` is the algebra morphism itself.
5. `equiv_monoid_algebra_free_monoid : free_algebra R X ≃ₐ[R] monoid_algebra R (free_monoid X)`
6. An inductive principle `induction`.

## Implementation details

We construct the free algebra on `X` as a quotient of an inductive type `free_algebra.pre` by an
inductively defined relation `free_algebra.rel`. Explicitly, the construction involves three steps:
1. We construct an inductive type `free_algebra.pre R X`, the terms of which should be thought
  of as representatives for the elements of `free_algebra R X`.
  It is the free type with maps from `R` and `X`, and with two binary operations `add` and `mul`.
2. We construct an inductive relation `free_algebra.rel R X` on `free_algebra.pre R X`.
  This is the smallest relation for which the quotient is an `R`-algebra where addition resp.
  multiplication are induced by `add` resp. `mul` from 1., and for which the map from `R` is the
  structure map for the algebra.
3. The free algebra `free_algebra R X` is the quotient of `free_algebra.pre R X` by
  the relation `free_algebra.rel R X`.
-/

variables (R : Type*) [comm_semiring R]
variables (X : Type*)

namespace free_algebra

/--
This inductive type is used to express representatives of the free algebra.
-/
inductive pre
| of : X → pre
| of_scalar : R → pre
| add : pre → pre → pre
| mul : pre → pre → pre

namespace pre

instance : inhabited (pre R X) := ⟨of_scalar 0⟩

-- Note: These instances are only used to simplify the notation.
/-- Coercion from `X` to `pre R X`. Note: Used for notation only. -/
def has_coe_generator : has_coe X (pre R X) := ⟨of⟩
/-- Coercion from `R` to `pre R X`. Note: Used for notation only. -/
def has_coe_semiring : has_coe R (pre R X) := ⟨of_scalar⟩
/-- Multiplication in `pre R X` defined as `pre.mul`. Note: Used for notation only. -/
def has_mul : has_mul (pre R X) := ⟨mul⟩
/-- Addition in `pre R X` defined as `pre.add`. Note: Used for notation only. -/
def has_add : has_add (pre R X) := ⟨add⟩
/-- Zero in `pre R X` defined as the image of `0` from `R`. Note: Used for notation only. -/
def has_zero : has_zero (pre R X) := ⟨of_scalar 0⟩
/-- One in `pre R X` defined as the image of `1` from `R`. Note: Used for notation only. -/
def has_one : has_one (pre R X) := ⟨of_scalar 1⟩
/--
Scalar multiplication defined as multiplication by the image of elements from `R`.
Note: Used for notation only.
-/
def has_scalar : has_scalar R (pre R X) := ⟨λ r m, mul (of_scalar r) m⟩

end pre

local attribute [instance]
  pre.has_coe_generator pre.has_coe_semiring pre.has_mul pre.has_add pre.has_zero
  pre.has_one pre.has_scalar

/--
Given a function from `X` to an `R`-algebra `A`, `lift_fun` provides a lift of `f` to a function
from `pre R X` to `A`. This is mainly used in the construction of `free_algebra.lift`.
-/
def lift_fun {A : Type*} [semiring A] [algebra R A] (f : X → A) : pre R X → A :=
  λ t, pre.rec_on t f (algebra_map _ _) (λ _ _, (+)) (λ _ _, (*))

/--
An inductively defined relation on `pre R X` used to force the initial algebra structure on
the associated quotient.
-/
inductive rel : (pre R X) → (pre R X) → Prop
-- force `of_scalar` to be a central semiring morphism
| add_scalar {r s : R} : rel ↑(r + s) (↑r + ↑s)
| mul_scalar {r s : R} : rel ↑(r * s) (↑r * ↑s)
| central_scalar {r : R} {a : pre R X} : rel (r * a) (a * r)
-- commutative additive semigroup
| add_assoc {a b c : pre R X} : rel (a + b + c) (a + (b + c))
| add_comm {a b : pre R X} : rel (a + b) (b + a)
| zero_add {a : pre R X} : rel (0 + a) a
-- multiplicative monoid
| mul_assoc {a b c : pre R X} : rel (a * b * c) (a * (b * c))
| one_mul {a : pre R X} : rel (1 * a) a
| mul_one {a : pre R X} : rel (a * 1) a
-- distributivity
| left_distrib {a b c : pre R X} : rel (a * (b + c)) (a * b + a * c)
| right_distrib {a b c : pre R X} : rel ((a + b) * c) (a * c + b * c)
-- other relations needed for semiring
| zero_mul {a : pre R X} : rel (0 * a) 0
| mul_zero {a : pre R X} : rel (a * 0) 0
-- compatibility
| add_compat_left {a b c : pre R X} : rel a b → rel (a + c) (b + c)
| add_compat_right {a b c : pre R X} : rel a b → rel (c + a) (c + b)
| mul_compat_left {a b c : pre R X} : rel a b → rel (a * c) (b * c)
| mul_compat_right {a b c : pre R X} : rel a b → rel (c * a) (c * b)

end free_algebra

/--
The free algebra for the type `X` over the commutative semiring `R`.
-/
def free_algebra := quot (free_algebra.rel R X)

namespace free_algebra

local attribute [instance]
  pre.has_coe_generator pre.has_coe_semiring pre.has_mul pre.has_add pre.has_zero
  pre.has_one pre.has_scalar

instance : semiring (free_algebra R X) :=
{ add := quot.map₂ (+) (λ _ _ _, rel.add_compat_right) (λ _ _ _, rel.add_compat_left),
  add_assoc := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.add_assoc },
  zero := quot.mk _ 0,
  zero_add := by { rintro ⟨⟩, exact quot.sound rel.zero_add },
  add_zero := begin
    rintros ⟨⟩,
    change quot.mk _ _ = _,
    rw [quot.sound rel.add_comm, quot.sound rel.zero_add],
  end,
  add_comm := by { rintros ⟨⟩ ⟨⟩, exact quot.sound rel.add_comm },
  mul := quot.map₂ (*) (λ _ _ _, rel.mul_compat_right) (λ _ _ _, rel.mul_compat_left),
  mul_assoc := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.mul_assoc },
  one := quot.mk _ 1,
  one_mul := by { rintros ⟨⟩, exact quot.sound rel.one_mul },
  mul_one := by { rintros ⟨⟩, exact quot.sound rel.mul_one },
  left_distrib := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.left_distrib },
  right_distrib := by { rintros ⟨⟩ ⟨⟩ ⟨⟩, exact quot.sound rel.right_distrib },
  zero_mul := by { rintros ⟨⟩, exact quot.sound rel.zero_mul },
  mul_zero := by { rintros ⟨⟩, exact quot.sound rel.mul_zero } }

instance : inhabited (free_algebra R X) := ⟨0⟩

instance : has_scalar R (free_algebra R X) :=
{ smul := λ r, quot.map ((*) ↑r) (λ a b, rel.mul_compat_right) }

instance : algebra R (free_algebra R X) :=
{ to_fun := λ r, quot.mk _ r,
  map_one' := rfl,
  map_mul' := λ _ _, quot.sound rel.mul_scalar,
  map_zero' := rfl,
  map_add' := λ _ _, quot.sound rel.add_scalar,
  commutes' := λ _, by { rintros ⟨⟩, exact quot.sound rel.central_scalar },
  smul_def' := λ _ _, rfl }

instance {S : Type*} [comm_ring S] : ring (free_algebra S X) := algebra.semiring_to_ring S

variables {X}

/--
The canonical function `X → free_algebra R X`.
-/
def ι : X → free_algebra R X := λ m, quot.mk _ m

@[simp] lemma quot_mk_eq_ι (m : X) : quot.mk (free_algebra.rel R X) m = ι R m := rfl

variables {A : Type*} [semiring A] [algebra R A]

/-- Internal definition used to define `lift` -/
private def lift_aux (f : X → A) : (free_algebra R X →ₐ[R] A) :=
{ to_fun := λ a, quot.lift_on a (lift_fun _ _ f) $ λ a b h,
  begin
    induction h,
    { exact (algebra_map R A).map_add h_r h_s, },
    { exact (algebra_map R A).map_mul h_r h_s },
    { apply algebra.commutes },
    { change _ + _ + _ = _ + (_ + _),
      rw add_assoc },
    { change _ + _ = _ + _,
      rw add_comm, },
    { change (algebra_map _ _ _) + lift_fun R X f _ = lift_fun R X f _,
      simp, },
    { change _ * _ * _ = _ * (_ * _),
      rw mul_assoc },
    { change (algebra_map _ _ _) * lift_fun R X f _ = lift_fun R X f _,
      simp, },
    { change lift_fun R X f _ * (algebra_map _ _ _) = lift_fun R X f _,
      simp, },
    { change _ * (_ + _) = _ * _ + _ * _,
      rw left_distrib, },
    { change (_ + _) * _ = _ * _ + _ * _,
      rw right_distrib, },
    { change (algebra_map _ _ _) * _ = algebra_map _ _ _,
      simp },
    { change _ * (algebra_map _ _ _) = algebra_map _ _ _,
      simp },
    repeat { change lift_fun R X f _ + lift_fun R X f _ = _,
      rw h_ih,
      refl, },
    repeat { change lift_fun R X f _ * lift_fun R X f _ = _,
      rw h_ih,
      refl, },
  end,
  map_one' := by { change algebra_map _ _ _ = _, simp },
  map_mul' := by { rintros ⟨⟩ ⟨⟩, refl },
  map_zero' := by { change algebra_map _ _ _ = _, simp },
  map_add' := by { rintros ⟨⟩ ⟨⟩, refl },
  commutes' := by tauto }

/--
Given a function `f : X → A` where `A` is an `R`-algebra, `lift R f` is the unique lift
of `f` to a morphism of `R`-algebras `free_algebra R X → A`.
-/
def lift : (X → A) ≃ (free_algebra R X →ₐ[R] A) :=
{ to_fun := lift_aux R,
  inv_fun := λ F, F ∘ (ι R),
  left_inv := λ f, by {ext, refl},
  right_inv := λ F, by
  { ext x,
    rcases x,
    induction x,
    case pre.of :
    { change ((F : free_algebra R X → A) ∘ (ι R)) _ = _,
      refl },
    case pre.of_scalar :
    { change algebra_map _ _ x = F (algebra_map _ _ x),
      rw alg_hom.commutes F x, },
    case pre.add : a b ha hb
    { change lift_aux R (F ∘ ι R) (quot.mk _ _ + quot.mk _ _) = F (quot.mk _ _ + quot.mk _ _),
      rw [alg_hom.map_add, alg_hom.map_add, ha, hb], },
    case pre.mul : a b ha hb
    { change lift_aux R (F ∘ ι R) (quot.mk _ _ * quot.mk _ _) = F (quot.mk _ _ * quot.mk _ _),
      rw [alg_hom.map_mul, alg_hom.map_mul, ha, hb], }, }, }

@[simp] lemma lift_aux_eq (f : X → A) : lift_aux R f = lift R f := rfl

@[simp]
lemma lift_symm_apply (F : free_algebra R X →ₐ[R] A) : (lift R).symm F = F ∘ (ι R) := rfl

variables {R X}

@[simp]
theorem ι_comp_lift (f : X → A) :
  (lift R f : free_algebra R X → A) ∘ (ι R) = f := by {ext, refl}

@[simp]
theorem lift_ι_apply (f : X → A) (x) :
  lift R f (ι R x) = f x := rfl

@[simp]
theorem lift_unique (f : X → A) (g : free_algebra R X →ₐ[R] A) :
  (g : free_algebra R X → A) ∘ (ι R) = f ↔ g = lift R f :=
(lift R).symm_apply_eq

/-!
At this stage we set the basic definitions as `@[irreducible]`, so from this point onwards one
should only use the universal properties of the free algebra, and consider the actual implementation
as a quotient of an inductive type as completely hidden.

Of course, one still has the option to locally make these definitions `semireducible` if so desired,
and Lean is still willing in some circumstances to do unification based on the underlying
definition.
-/
attribute [irreducible] ι lift
-- Marking `free_algebra` irreducible makes `ring` instances inaccessible on quotients.
-- https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/algebra.2Esemiring_to_ring.20breaks.20semimodule.20typeclass.20lookup/near/212580241
-- For now, we avoid this by not marking it irreducible.

@[simp]
theorem lift_comp_ι (g : free_algebra R X →ₐ[R] A) :
  lift R ((g : free_algebra R X → A) ∘ (ι R)) = g :=
by { rw ←lift_symm_apply, exact (lift R).apply_symm_apply g }

/-- See note [partially-applied ext lemmas]. -/
@[ext]
theorem hom_ext {f g : free_algebra R X →ₐ[R] A}
  (w : ((f : free_algebra R X → A) ∘ (ι R)) = ((g : free_algebra R X → A) ∘ (ι R))) : f = g :=
begin
  rw [←lift_symm_apply, ←lift_symm_apply] at w,
  exact (lift R).symm.injective w,
end

/--
The free algebra on `X` is "just" the monoid algebra on the free monoid on `X`.

This would be useful when constructing linear maps out of a free algebra,
for example.
-/
noncomputable
def equiv_monoid_algebra_free_monoid : free_algebra R X ≃ₐ[R] monoid_algebra R (free_monoid X) :=
alg_equiv.of_alg_hom
  (lift R (λ x, (monoid_algebra.of R (free_monoid X)) (free_monoid.of x)))
  ((monoid_algebra.lift R (free_monoid X) (free_algebra R X)) (free_monoid.lift (ι R)))
begin
  apply monoid_algebra.alg_hom_ext, intro x,
  apply free_monoid.rec_on x,
  { simp, refl, },
  { intros x y ih, simp at ih, simp [ih], }
end
(by { ext, simp, })

instance [nontrivial R] : nontrivial (free_algebra R X) :=
equiv_monoid_algebra_free_monoid.surjective.nontrivial

section
open_locale classical

/-- The left-inverse of `algebra_map`. -/
def algebra_map_inv : free_algebra R X →ₐ[R] R :=
lift R (0 : X → R)

lemma algebra_map_left_inverse :
  function.left_inverse algebra_map_inv (algebra_map R $ free_algebra R X) :=
λ x, by simp [algebra_map_inv]

@[simp] lemma algebra_map_inj (x y : R) :
  algebra_map R (free_algebra R X) x = algebra_map R (free_algebra R X) y ↔ x = y :=
algebra_map_left_inverse.injective.eq_iff

@[simp] lemma algebra_map_eq_zero_iff (x : R) : algebra_map R (free_algebra R X) x = 0 ↔ x = 0 :=
algebra_map_inj x 0

@[simp] lemma algebra_map_eq_one_iff (x : R) : algebra_map R (free_algebra R X) x = 1 ↔ x = 1 :=
algebra_map_inj x 1

-- this proof is copied from the approach in `free_abelian_group.of_injective`
lemma ι_injective [nontrivial R] : function.injective (ι R : X → free_algebra R X) :=
λ x y hoxy, classical.by_contradiction $ assume hxy : x ≠ y,
  let f : free_algebra R X →ₐ[R] R := lift R (λ z, if x = z then (1 : R) else 0) in
  have hfx1 : f (ι R x) = 1, from (lift_ι_apply _ _).trans $ if_pos rfl,
  have hfy1 : f (ι R y) = 1, from hoxy ▸ hfx1,
  have hfy0 : f (ι R y) = 0, from (lift_ι_apply _ _).trans $ if_neg hxy,
  one_ne_zero $ hfy1.symm.trans hfy0

@[simp] lemma ι_inj [nontrivial R] (x y : X) : ι R x = ι R y ↔ x = y :=
ι_injective.eq_iff

@[simp] lemma ι_ne_algebra_map [nontrivial R] (x : X) (r : R) : ι R x ≠ algebra_map R _ r :=
λ h,
  let f0 : free_algebra R X →ₐ[R] R := lift R 0 in
  let f1 : free_algebra R X →ₐ[R] R := lift R 1 in
  have hf0 : f0 (ι R x) = 0, from lift_ι_apply _ _,
  have hf1 : f1 (ι R x) = 1, from lift_ι_apply _ _,
  begin
    rw [h, f0.commutes, algebra.id.map_eq_self] at hf0,
    rw [h, f1.commutes, algebra.id.map_eq_self] at hf1,
    exact zero_ne_one (hf0.symm.trans hf1),
  end

@[simp] lemma ι_ne_zero [nontrivial R] (x : X) : ι R x ≠ 0 :=
ι_ne_algebra_map x 0

@[simp]

end

end free_algebra

/- There is something weird in the above namespace that breaks the typeclass resolution of
`has_coe_to_sort` below. Closing it and reopening it fixes it... -/
namespace free_algebra

/-- An induction principle for the free algebra.

If `C` holds for the `algebra_map` of `r : R` into `free_algebra R X`, the `ι` of `x : X`, and is
preserved under addition and muliplication, then it holds for all of `free_algebra R X`.
-/
@[elab_as_eliminator]
lemma induction {C : free_algebra R X → Prop}
  (h_grade0 : ∀ r, C (algebra_map R (free_algebra R X) r))
  (h_grade1 : ∀ x, C (ι R x))
  (h_mul : ∀ a b, C a → C b → C (a * b))
  (h_add : ∀ a b, C a → C b → C (a + b))
  (a : free_algebra R X) :
  C a :=
begin
  -- the arguments are enough to construct a subalgebra, and a mapping into it from X
  let s : subalgebra R (free_algebra R X) :=
  { carrier := C,
    mul_mem' := h_mul,
    add_mem' := h_add,
    algebra_map_mem' := h_grade0, },
  let of : X → s := subtype.coind (ι R) h_grade1,
  -- the mapping through the subalgebra is the identity
  have of_id : alg_hom.id R (free_algebra R X) = s.val.comp (lift R of),
  { ext,
    simp [of, subtype.coind], },
  -- finding a proof is finding an element of the subalgebra
  convert subtype.prop (lift R of a),
  simp [alg_hom.ext_iff] at of_id,
  exact of_id a,
end

/-- The star ring formed by reversing the elements of products -/
instance : star_ring (free_algebra R X) :=
{ star := mul_opposite.unop ∘ lift R (mul_opposite.op ∘ ι R),
  star_involutive := λ x, by
  { unfold has_star.star,
    simp only [function.comp_apply],
    refine free_algebra.induction R X _ _ _ _ x; intros; simp [*] },
  star_mul := λ a b, by simp,
  star_add := λ a b, by simp }

@[simp]
lemma star_ι (x : X) : star (ι R x) = (ι R x) :=
by simp [star, has_star.star]

@[simp]
lemma star_algebra_map (r : R) : star (algebra_map R (free_algebra R X) r) = (algebra_map R _ r) :=
by simp [star, has_star.star]

/-- `star` as an `alg_equiv` -/
def star_hom : free_algebra R X ≃ₐ[R] (free_algebra R X)ᵐᵒᵖ :=
{ commutes' := λ r, by simp [star_algebra_map],
  ..star_ring_equiv }

end free_algebra


import data.real.basic
import data.polynomial.derivative
import linear_algebra.basic
import linear_algebra.finite_dimensional

-- On se place dans le R -espace vectoriel E = R[X] .
-- (a) Soit H un sous-espace vectoriel de dimension finie et f un endomorphisme de H. Montrer qu'il existe p ∈ N tel que
--    ∀k ≥ p, Ker f k+1 = Ker f k.
--
-- Soit F un sous-espace vectoriel de E stable par l'opérateur D de dérivation.
-- (b) On suppose que F est de dimension finie non nulle. Montrer que l'endomorphisme induit par D sur R n [X] est nilpotent pour tout n ∈ N .
-- Montrer qu'il existe m ∈ N tel que F = R m [X] .
-- (c) Montrer que si F est de dimension innie alors F = R[X] .
-- (d) Soit g ∈ L(E) tel que g^2 = kId + D avec k ∈ R . Quel est le signe de k ?

theorem d:
  forall g: (polynomial real) →ₗ[real] (polynomial real),
     (exists k: real, (g^2 = k • linear_map.id + polynomial.derivative))
  -> (forall k: real, (g^2 = k • linear_map.id + polynomial.derivative) -> k > 0)
:= sorry


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

import data.mv_polynomial.rename
import data.equiv.fin
import data.polynomial.algebra_map

/-!
# Equivalences between polynomial rings

This file establishes a number of equivalences between polynomial rings,
based on equivalences between the underlying types.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ : Type*` (indexing the variables)

+ `R : Type*` `[comm_semiring R]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `a : R`

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ R`

## Tags

equivalence, isomorphism, morphism, ring hom, hom

-/

noncomputable theory

open_locale classical big_operators

open set function finsupp add_monoid_algebra

universes u v w x
variables {R : Type u} {S₁ : Type v} {S₂ : Type w} {S₃ : Type x}

namespace mv_polynomial
variables {σ : Type*} {a a' a₁ a₂ : R} {e : ℕ} {n m : σ} {s : σ →₀ ℕ}

section equiv

variables (R) [comm_semiring R]

/--
The ring isomorphism between multivariable polynomials in a single variable and
polynomials over the ground ring.
-/
@[simps]
def punit_alg_equiv : mv_polynomial punit R ≃ₐ[R] polynomial R :=
{ to_fun    := eval₂ polynomial.C (λu:punit, polynomial.X),
  inv_fun   := polynomial.eval₂ mv_polynomial.C (X punit.star),
  left_inv  :=
    begin
      let f : polynomial R →+* mv_polynomial punit R :=
        (polynomial.eval₂_ring_hom mv_polynomial.C (X punit.star)),
      let g : mv_polynomial punit R →+* polynomial R :=
        (eval₂_hom polynomial.C (λu:punit, polynomial.X)),
      show ∀ p, f.comp g p = p,
      apply is_id,
      { ext a, dsimp, rw [eval₂_C, polynomial.eval₂_C] },
      { rintros ⟨⟩, dsimp, rw [eval₂_X, polynomial.eval₂_X] }
    end,
  right_inv := assume p, polynomial.induction_on p
    (assume a, by rw [polynomial.eval₂_C, mv_polynomial.eval₂_C])
    (assume p q hp hq, by rw [polynomial.eval₂_add, mv_polynomial.eval₂_add, hp, hq])
    (assume p n hp,
      by rw [polynomial.eval₂_mul, polynomial.eval₂_pow, polynomial.eval₂_X, polynomial.eval₂_C,
        eval₂_mul, eval₂_C, eval₂_pow, eval₂_X]),
  map_mul'  := λ _ _, eval₂_mul _ _,
  map_add'  := λ _ _, eval₂_add _ _,
  commutes' := λ _, eval₂_C _ _ _}

section map
variables {R} (σ)

/-- If `e : A ≃+* B` is an isomorphism of rings, then so is `map e`. -/
@[simps apply]
def map_equiv [comm_semiring S₁] [comm_semiring S₂] (e : S₁ ≃+* S₂) :
  mv_polynomial σ S₁ ≃+* mv_polynomial σ S₂ :=
{ to_fun    := map (e : S₁ →+* S₂),
  inv_fun   := map (e.symm : S₂ →+* S₁),
  left_inv  := map_left_inverse e.left_inv,
  right_inv := map_right_inverse e.right_inv,
  ..map (e : S₁ →+* S₂) }

@[simp] lemma map_equiv_refl :
  map_equiv σ (ring_equiv.refl R) = ring_equiv.refl _ :=
ring_equiv.ext map_id

@[simp] lemma map_equiv_symm [comm_semiring S₁] [comm_semiring S₂] (e : S₁ ≃+* S₂) :
  (map_equiv σ e).symm = map_equiv σ e.symm := rfl

@[simp] lemma map_equiv_trans [comm_semiring S₁] [comm_semiring S₂] [comm_semiring S₃]
  (e : S₁ ≃+* S₂) (f : S₂ ≃+* S₃) :
  (map_equiv σ e).trans (map_equiv σ f) = map_equiv σ (e.trans f) :=
ring_equiv.ext (map_map e f)

variables {A₁ A₂ A₃ : Type*} [comm_semiring A₁] [comm_semiring A₂] [comm_semiring A₃]
variables [algebra R A₁] [algebra R A₂] [algebra R A₃]

/-- If `e : A ≃ₐ[R] B` is an isomorphism of `R`-algebras, then so is `map e`. -/
@[simps apply]
def map_alg_equiv (e : A₁ ≃ₐ[R] A₂) :
  mv_polynomial σ A₁ ≃ₐ[R] mv_polynomial σ A₂ :=
{ to_fun := map (e : A₁ →+* A₂),
  ..map_alg_hom (e : A₁ →ₐ[R] A₂),
  ..map_equiv σ (e : A₁ ≃+* A₂) }

@[simp] lemma map_alg_equiv_refl :
  map_alg_equiv σ (alg_equiv.refl : A₁ ≃ₐ[R] A₁) = alg_equiv.refl :=
alg_equiv.ext map_id

@[simp] lemma map_alg_equiv_symm (e : A₁ ≃ₐ[R] A₂) :
  (map_alg_equiv σ e).symm = map_alg_equiv σ e.symm := rfl

@[simp] lemma map_alg_equiv_trans (e : A₁ ≃ₐ[R] A₂) (f : A₂ ≃ₐ[R] A₃) :
  (map_alg_equiv σ e).trans (map_alg_equiv σ f) = map_alg_equiv σ (e.trans f) :=
alg_equiv.ext (map_map e f)

end map

section
variables (S₁ S₂ S₃)

/--
The function from multivariable polynomials in a sum of two types,
to multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.

See `sum_ring_equiv` for the ring isomorphism.
-/
def sum_to_iter : mv_polynomial (S₁ ⊕ S₂) R →+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
eval₂_hom (C.comp C) (λbc, sum.rec_on bc X (C ∘ X))

@[simp]
lemma sum_to_iter_C (a : R) : sum_to_iter R S₁ S₂ (C a) = C (C a) :=
eval₂_C _ _ a

@[simp]
lemma sum_to_iter_Xl (b : S₁) : sum_to_iter R S₁ S₂ (X (sum.inl b)) = X b :=
eval₂_X _ _ (sum.inl b)

@[simp]
lemma sum_to_iter_Xr (c : S₂) : sum_to_iter R S₁ S₂ (X (sum.inr c)) = C (X c) :=
eval₂_X _ _ (sum.inr c)

/--
The function from multivariable polynomials in one type,
with coefficents in multivariable polynomials in another type,
to multivariable polynomials in the sum of the two types.

See `sum_ring_equiv` for the ring isomorphism.
-/
def iter_to_sum : mv_polynomial S₁ (mv_polynomial S₂ R) →+* mv_polynomial (S₁ ⊕ S₂) R :=
eval₂_hom (eval₂_hom C (X ∘ sum.inr)) (X ∘ sum.inl)

lemma iter_to_sum_C_C (a : R) : iter_to_sum R S₁ S₂ (C (C a)) = C a :=
eq.trans (eval₂_C _ _ (C a)) (eval₂_C _ _ _)

lemma iter_to_sum_X (b : S₁) : iter_to_sum R S₁ S₂ (X b) = X (sum.inl b) :=
eval₂_X _ _ _

lemma iter_to_sum_C_X (c : S₂) : iter_to_sum R S₁ S₂ (C (X c)) = X (sum.inr c) :=
eq.trans (eval₂_C _ _ (X c)) (eval₂_X _ _ _)

variable (σ)

/-- The algebra isomorphism between multivariable polynomials in no variables
and the ground ring. -/
@[simps] def is_empty_alg_equiv [he : is_empty σ] : mv_polynomial σ R ≃ₐ[R] R :=
alg_equiv.of_alg_hom
  (aeval (is_empty.elim he))
  (algebra.of_id _ _)
  (by { ext, simp [algebra.of_id_apply, algebra_map_eq] })
  (by { ext i m, exact is_empty.elim' he i })

/-- The ring isomorphism between multivariable polynomials in no variables
and the ground ring. -/
@[simps] def is_empty_ring_equiv [he : is_empty σ] : mv_polynomial σ R ≃+* R :=
(is_empty_alg_equiv R σ).to_ring_equiv

variable {σ}

/-- A helper function for `sum_ring_equiv`. -/
@[simps]
def mv_polynomial_equiv_mv_polynomial [comm_semiring S₃]
  (f : mv_polynomial S₁ R →+* mv_polynomial S₂ S₃)
  (g : mv_polynomial S₂ S₃ →+* mv_polynomial S₁ R)
  (hfgC : (f.comp g).comp C = C)
  (hfgX : ∀n, f (g (X n)) = X n)
  (hgfC : (g.comp f).comp C = C)
  (hgfX : ∀n, g (f (X n)) = X n) :
  mv_polynomial S₁ R ≃+* mv_polynomial S₂ S₃ :=
{ to_fun    := f, inv_fun := g,
  left_inv  := is_id (ring_hom.comp _ _) hgfC hgfX,
  right_inv := is_id (ring_hom.comp _ _) hfgC hfgX,
  map_mul'  := f.map_mul,
  map_add'  := f.map_add }

/--
The ring isomorphism between multivariable polynomials in a sum of two types,
and multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.
-/
def sum_ring_equiv : mv_polynomial (S₁ ⊕ S₂) R ≃+* mv_polynomial S₁ (mv_polynomial S₂ R) :=
begin
  apply @mv_polynomial_equiv_mv_polynomial R (S₁ ⊕ S₂) _ _ _ _
    (sum_to_iter R S₁ S₂) (iter_to_sum R S₁ S₂),
  { refine ring_hom.ext (λ p, _),
    rw [ring_hom.comp_apply],
    convert hom_eq_hom ((sum_to_iter R S₁ S₂).comp ((iter_to_sum R S₁ S₂).comp C)) C _ _ p,
    { ext1 a, dsimp, rw [iter_to_sum_C_C R S₁ S₂, sum_to_iter_C R S₁ S₂] },
    { assume c, dsimp, rw [iter_to_sum_C_X R S₁ S₂, sum_to_iter_Xr R S₁ S₂] } },
  { assume b, rw [iter_to_sum_X R S₁ S₂, sum_to_iter_Xl R S₁ S₂] },
  { ext1 a, rw [ring_hom.comp_apply, ring_hom.comp_apply,
      sum_to_iter_C R S₁ S₂, iter_to_sum_C_C R S₁ S₂] },
  { assume n, cases n with b c,
    { rw [sum_to_iter_Xl, iter_to_sum_X] },
    { rw [sum_to_iter_Xr, iter_to_sum_C_X] } },
end

/--
The algebra isomorphism between multivariable polynomials in a sum of two types,
and multivariable polynomials in one of the types,
with coefficents in multivariable polynomials in the other type.
-/
def sum_alg_equiv : mv_polynomial (S₁ ⊕ S₂) R ≃ₐ[R]
  mv_polynomial S₁ (mv_polynomial S₂ R) :=
{ commutes' := begin
    intro r,
    have A : algebra_map R (mv_polynomial S₁ (mv_polynomial S₂ R)) r = (C (C r) : _), by refl,
    have B : algebra_map R (mv_polynomial (S₁ ⊕ S₂) R) r = C r, by refl,
    simp only [sum_ring_equiv, sum_to_iter_C, mv_polynomial_equiv_mv_polynomial_apply,
      ring_equiv.to_fun_eq_coe, A, B],
  end,
  ..sum_ring_equiv R S₁ S₂ }

section

-- this speeds up typeclass search in the lemma below
local attribute [instance, priority 2000] is_scalar_tower.right

/--
The algebra isomorphism between multivariable polynomials in `option S₁` and
polynomials with coefficients in `mv_polynomial S₁ R`.
-/
@[simps] def option_equiv_left :
  mv_polynomial (option S₁) R ≃ₐ[R] polynomial (mv_polynomial S₁ R) :=
alg_equiv.of_alg_hom
  (mv_polynomial.aeval (λ o, o.elim polynomial.X (λ s, polynomial.C (X s))))
  (polynomial.aeval_tower (mv_polynomial.rename some) (X none))
  (by ext : 2; simp [← polynomial.C_eq_algebra_map])
  (by ext i : 2; cases i; simp)

end

/--
The algebra isomorphism between multivariable polynomials in `option S₁` and
multivariable polynomials with coefficients in polynomials.
-/
def option_equiv_right : mv_polynomial (option S₁) R ≃ₐ[R] mv_polynomial S₁ (polynomial R) :=
alg_equiv.of_alg_hom
  (mv_polynomial.aeval (λ o, o.elim (C polynomial.X) X))
  (mv_polynomial.aeval_tower (polynomial.aeval (X none)) (λ i, X (option.some i)))
  (by ext : 2; simp [mv_polynomial.algebra_map_eq])
  (by ext i : 2; cases i; simp)

/--
The algebra isomorphism between multivariable polynomials in `fin (n + 1)` and
polynomials over multivariable polynomials in `fin n`.
-/
def fin_succ_equiv (n : ℕ) :
  mv_polynomial (fin (n + 1)) R ≃ₐ[R] polynomial (mv_polynomial (fin n) R) :=
(rename_equiv R (fin_succ_equiv n)).trans
  (option_equiv_left R (fin n))

lemma fin_succ_equiv_eq (n : ℕ) :
  (fin_succ_equiv R n : mv_polynomial (fin (n + 1)) R →+* polynomial (mv_polynomial (fin n) R)) =
  eval₂_hom (polynomial.C.comp (C : R →+* mv_polynomial (fin n) R))
    (λ i : fin (n+1), fin.cases polynomial.X (λ k, polynomial.C (X k)) i) :=
begin
  ext : 2,
  { simp only [fin_succ_equiv, option_equiv_left_apply, aeval_C, alg_equiv.coe_trans,
      alg_equiv.coe_alg_hom, coe_eval₂_hom, alg_hom.coe_to_ring_hom, comp_app, rename_equiv_apply,
      eval₂_C, ring_hom.coe_comp, coe_coe, rename_C],
    refl },
  { intro i,
    refine fin.cases _ _ i;
    simp [fin_succ_equiv] }
end

@[simp] lemma fin_succ_equiv_apply (n : ℕ) (p : mv_polynomial (fin (n + 1)) R) :
  fin_succ_equiv R n p =
  eval₂_hom (polynomial.C.comp (C : R →+* mv_polynomial (fin n) R))
    (λ i : fin (n+1), fin.cases polynomial.X (λ k, polynomial.C (X k)) i) p :=
by { rw ← fin_succ_equiv_eq, refl }

lemma fin_succ_equiv_comp_C_eq_C {R : Type u} [comm_semiring R] (n : ℕ) :
  (↑(mv_polynomial.fin_succ_equiv R n).symm : polynomial (mv_polynomial (fin n) R) →+* _).comp
    ((polynomial.C).comp (mv_polynomial.C))
    = (mv_polynomial.C : R →+* mv_polynomial (fin n.succ) R) :=
begin
  refine ring_hom.ext (λ x, _),
  rw ring_hom.comp_apply,
  refine (mv_polynomial.fin_succ_equiv R n).injective
    (trans ((mv_polynomial.fin_succ_equiv R n).apply_symm_apply _) _),
  simp only [mv_polynomial.fin_succ_equiv_apply, mv_polynomial.eval₂_hom_C],
end

end

end equiv

end mv_polynomial


import lambda_calculus.utlc.basic

namespace lambda_calculus
namespace utlc

variables {n m : ℕ}
variables {f g: utlc}
local attribute [simp] down_shift

theorem size_pos (f: utlc): 0 < f.size := by
{ cases f, all_goals { simp}  }

theorem size_pos' (f: utlc): 1 ≤ f.size := nat.one_le_of_lt (size_pos f)

@[simp] theorem shift_inj_helper (x y n: ℕ): ite (x < n) x (x + 1) = ite (y < n) y (y + 1) ↔ x = y :=
begin
  split_ifs;
  try { exact id };
  try { exact add_right_cancel };
  split;
  intro _;
  linarith
end

@[simp] theorem shift_inj_iff {f: utlc} (n: nat) {g: utlc}: f ↑¹ n = g ↑¹ n ↔ f = g :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing n g;
  induction g using lambda_calculus.utlc.notation_cases_on,
  { simp }, { simp }, { simp },
  { simp }, { simp [f_ih] }, { simp },
  { simp }, { simp }, { simp [f_ih_f, f_ih_g] },
end

theorem shift_comm (h: n ≤ m) (f: utlc): f ↑¹ n ↑¹ (m+1) = f ↑¹ m ↑¹ n :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing n m,
  { simp only [down_shift],
    split_ifs;
    try { { refl } };
    exfalso;
    linarith },
  { simp [f_ih (nat.succ_le_succ h)] },
  { simp [f_ih_f h, f_ih_g h] }
end

@[simp] theorem shift_comm_zero (f: utlc): f ↑¹ n ↑¹ 0 = f ↑¹ 0 ↑¹ (n + 1) :=
 (shift_comm (nat.zero_le _) _).symm

theorem shift_comm' (h: n < m) (f: utlc) : f ↑¹ n ↑¹ m = f ↑¹ (m-1) ↑¹ n :=
begin
  cases m,
  { revert h, simp },
  { exact shift_comm (nat.le_of_lt_succ h) _ },
end

@[simp] theorem size_shift (f: utlc) (n: ℕ): (f ↑¹ n).size = f.size :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing n,
  { simp },
  { simp [f_ih] },
  { simp[f_ih_f, f_ih_g] }
end

lemma down_shift_uses_lt {n m: ℕ}: n < m → ∀ (x: ℕ), (↓x ↑¹ n:utlc).uses m = (↓x:utlc).uses (m - 1) :=
begin
  cases m,
  { simp },
  rw [nat.succ_eq_add_one, nat.add_sub_cancel],
  intros hnm x,
  obtain hxm|hxm|hxm := nat.lt_trichotomy x m,
  { simp [hxm, ne_of_lt hxm, ite_eq_iff, show (x < n → ¬ x = m + 1) ↔ true, by rw [iff_true]; intro; linarith] },
  { simp [hxm, not_lt_of_ge (nat.le_of_lt_succ hnm)] },
  { simp [hxm, ne_of_gt hxm, show ¬ x < n, by linarith] }
end

lemma down_shift_uses_eq (n x: ℕ): (↓x ↑¹ n:utlc).uses n = 0 :=
by simp [down_shift, uses, ite_eq_iff,
  show ¬ (x < n ∧ x = n), by intro; linarith,
  show (n ≤ x → ¬ x + 1 = n) ↔ true , by rw [iff_true]; intros _ _; linarith ]

lemma down_shift_uses_gt {n m: ℕ}: m < n → ∀ (x: ℕ), (↓x ↑¹ n:utlc).uses m = (↓x:utlc).uses m :=
begin
  intros hnm x,
  by_cases x = m,
  { simp [h, not_le_of_lt hnm] },
  simp [h, ite_eq_iff,
    show (n ≤ x → ¬ x + 1 = m) ↔ true , by rw [iff_true]; intros _ _; linarith]
end

theorem shift_uses (f: utlc) (n m: ℕ):
  (f ↑¹ n).uses m =
  if n < m then f.uses (m - 1)
  else if n = m then 0
  else f.uses m :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing n m,
  { obtain h|h|h := nat.lt_trichotomy n m,
    { simp only [h, if_true],
      exact down_shift_uses_lt h _ },
    { rw [h],
      simp only [lt_self_iff_false, if_false, eq_self_iff_true m, if_true],
      exact down_shift_uses_eq _ _ },
    { simp only [not_lt_of_gt h, ne_of_gt h, if_false],
      exact down_shift_uses_gt h _ } },
  { simp only [f_ih, lambda_shift, lambda_uses,
    add_right_cancel_iff, add_lt_add_iff_right],
    split_ifs;
    try { { refl } },
    rw [nat.sub_add_comm (nat.one_le_of_lt h)] },
  { simp only [ f_ih_f, f_ih_g, dot_shift, dot_uses],
    split_ifs;
    refl }
end

theorem shift_uses_lt {n m: ℕ} (h: n < m): ∀ (f: utlc), (f ↑¹ n).uses m = f.uses (m - 1) :=
by simp [shift_uses, h]

@[simp]
theorem shift_uses_zero_succ (f: utlc) (n: ℕ): (f ↑¹ 0).uses (n+1) = f.uses n := shift_uses_lt (nat.zero_lt_succ n) f

@[simp]
theorem shift_uses_self (f: utlc) (n: ℕ) : (f ↑¹ n).uses n = 0 :=
by simp [shift_uses]

theorem shift_of_uses_zero {f: utlc} {n: ℕ}: f.uses n = 0 → ∃ g, f = g ↑¹ n :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing n,
  { intro p,
    obtain h|h|h := nat.lt_trichotomy f n,
    { use f, simp [h] },
    { revert p, simp [h] },
    cases f,
    { revert h, simp },
    use f,
    rw [nat.succ_eq_add_one] at *,
    simp [show ¬ f < n, by linarith] },
  { intro p,
    cases f_ih p with g ih,
    use Λ g,
    simp [ih] },
  { rw [dot_uses, add_eq_zero_iff, and_imp],
    intros p q,
    cases f_ih_f p with x ihx,
    cases f_ih_g q with y ihy,
    use x·y,
    simp [ihx, ihy], }
end

theorem shift_succ_of_uses_zero: f.uses n = 0 → f ↑¹ (n+1) = f ↑¹ n :=
begin
  induction f generalizing n,
  { have h_iff : ∀ {α: Type*} (p q: Prop) (a b: α)
      [dp: decidable p] [dq: decidable q],
      (@ite _ _ dp a b = @ite _ _ dq a b) ↔ ((p ↔ q) ∨ a = b),
    { intros _ p q a b _ _,
      split_ifs;
      simp[h, h_1, @comm _ eq] },
    simpa [
      show f < n + 1 ↔ f ≤ n, by exact ⟨ nat.le_of_lt_succ, nat.succ_le_succ ⟩,
      h_iff (f ≤ n) (f < n) f (f+1), iff_def,
      eq_true_intro (le_of_lt)] using flip (@lt_of_le_of_ne _ _ f n) },
  { simpa using f_ih },
  { simpa using λ x y, and.intro (f_ih_f x) (f_ih_g y) }
end

theorem closed_below_iff_uses_zero (f: utlc) (n : ℕ) : f.closed_below n ↔ ∀ m, n ≤ m → f.uses m = 0 :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on
    with _ _ fh _ _ fh gh generalizing n,
  { have hlt: ∀ x y : ℕ, (∀ z, x ≤ z → y = z → false) ↔ y < x,
    { intros x y,
      split,
      { intro h,
        contrapose! h,
        exact ⟨y, h, rfl, not_false⟩ },
      intros hyx z hxz,
      exact ne_of_lt (lt_of_lt_of_le hyx hxz) },
    simp [closed_below, hlt] },
  { rw [closed_below, fh (n + 1)],
    split,
    { intros h m hnm,
      rw [lambda_uses, h _ (nat.succ_le_succ hnm)] },
    intros h m,
    cases m,
    { simp },
    rw [nat.succ_eq_add_one, add_le_add_iff_right, ← lambda_uses],
    exact h _ },
  { simp [down_closed_below, fh, gh, forall_and_distrib] }
end

theorem closed_below_mono: n ≤ m → f.closed_below n → f.closed_below m :=
begin
  induction f generalizing n m,
  { simpa [closed_below] using flip lt_of_lt_of_le },
  { simpa [← @nat.succ_le_succ_iff n m, ← nat.succ_eq_add_one]
      using @f_ih n.succ m.succ },
  { intro h,
    simpa using λ x y, and.intro (f_ih_f h x) (f_ih_g h y) }
end

theorem closed_below_mono': f.closed_below n → n ≤ m → f.closed_below m := flip closed_below_mono

theorem shift_of_closed_below:
  f.closed_below n → f ↑¹ n = f :=
begin
  induction f generalizing n,
  { simpa [closed_below] using not_le_of_gt },
  { simpa using f_ih },
  { simpa using λ x y, and.intro (f_ih_f x) (f_ih_g y) }
end

theorem shift_of_closed {f: utlc}:
  f.closed → ∀ n, f ↑¹ n = f := λ p n, shift_of_closed_below (closed_below_mono (nat.zero_le _) p)

theorem shift_closed_below (m: ℕ):
  f.closed_below n → (f ↑¹ m).closed_below (n+1) :=
begin
  simp only [closed_below_iff_uses_zero, shift_uses],
  intros h m,
  cases m,
  { simp },
  rw [nat.succ_eq_add_one, nat.add_sub_cancel, nat.add_le_add_iff_right],
  intro hnm,
  split_ifs,
  { exact h _ hnm },
  { refl },
  apply h,
  linarith,
end

local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

theorem substitution_uses_le {n m: ℕ} (hnm: n ≤ m) (f g: utlc):
  f[n:=g].uses m = f.uses (m + 1) + f.uses n * g.uses m :=
begin
  induction f generalizing n m g,
  { obtain hfn|hfn|hfn := nat.lt_trichotomy f n,
    { simp[hfn, ne_of_lt hfn,
        show f ≠ m, by linarith,
        show f ≠ m + 1, by linarith] },
    { simp [hfn, ne_of_lt (nat.lt_succ_of_le hnm)] },
    simp [lt_asymm hfn, ne_of_gt hfn,
      nat.sub_eq_iff_eq_add (nat.one_le_of_lt hfn)] },
  { simp [f_ih _ (nat.succ_le_succ hnm)] },
  { simp [f_ih_f _ hnm, f_ih_g _ hnm,
      add_mul, ← nat.add_assoc,
      nat.add_right_comm (f_f.uses (m + 1)) _ (f_g.uses (m + 1))] }
end

theorem substitution_uses_gt {n m: ℕ} (hnm: m < n) (f g: utlc):
  f[n:=g].uses m = f.uses m + f.uses n * g.uses m :=
begin
  induction f generalizing n m g,
  { obtain hfn|hfn|hfn := nat.lt_trichotomy f n,
    { simp[hfn, ne_of_lt hfn] },
    { simp[hfn, ne_of_gt hnm] },
    simp [lt_asymm hfn, ne_of_gt hfn, ne_of_gt (trans hnm hfn),
      show f - 1 ≠ m, begin
        cases f,
        { revert hfn, simp },
        rw [nat.succ_eq_add_one, nat.add_sub_cancel],
        intro hfm,
        rw [hfm] at hfn,
        apply not_lt_of_ge (nat.le_of_lt_succ hfn) hnm
      end] },
  { simp[f_ih _ (nat.succ_lt_succ hnm)] },
  { simp [f_ih_f _ hnm, f_ih_g _ hnm,
      add_mul, ← nat.add_assoc,
      nat.add_right_comm (f_f.uses m) _ (f_g.uses m)] }
end

theorem substitution_uses (f: utlc) (n: ℕ) (g: utlc) (m: ℕ):
  f[n:=g].uses m = f.uses (ite (n ≤ m) (m + 1) m) + f.uses n * g.uses m :=
begin
  by_cases n ≤ m,
  { simp [substitution_uses_le h, h] },
  { simp [substitution_uses_gt (lt_of_not_ge h), h] }
end

@[simp]
theorem down_substitution_self (n:ℕ) (f:utlc): (↓n)[n:=f] = f := by simp

@[simp]
theorem shift_succ_substitiution_down (n:ℕ) (f:utlc): (f ↑¹ (n+1))[n:=↓n] = f := begin
  induction f generalizing n,
  { obtain h|h|h := nat.lt_trichotomy f n,
    { simp [trans h (nat.lt_succ_self _), ne_of_lt h, not_le_of_gt h] },
    { simp[h] },
    simp [
      show ¬ f < n + 1, by linarith,
      show ¬ f + 1 < n, by linarith,
      show ¬ f + 1 = n, by linarith] },
  { simp[f_ih] },
  { simp [f_ih_f, f_ih_g] }
end

@[simp] theorem substitution_of_shift (f: utlc) (n: ℕ) (g: utlc): (f ↑¹ n)[n:=g] = f :=
begin
  induction f generalizing n g,
  { obtain h|h|h := nat.lt_trichotomy f n,
    { simp[h] },
    { simp [h]},
    simp [lt_asymm h,
      show ¬ f + 1 < n, by linarith,
      show ¬ f + 1 = n, by linarith] },
  { simp[f_ih] },
  { simp[f_ih_f, f_ih_g] }
end

theorem substitution_of_unused: f.uses n = 0 → ∀ g, (f ↑¹ (n + 1)) [n:=g] = f :=
by intros h g; rw [shift_succ_of_uses_zero h, substitution_of_shift]

theorem substitution_of_closed_below:
  f.closed_below n → ∀ g, f[n:=g] = f :=
begin
  intros h g,
  conv_lhs { rw [← shift_of_closed_below h] },
  exact substitution_of_shift _ _ _
end

theorem substitution_of_closed: f.closed → ∀ n g, f[n:=g] = f :=
  λ p n, substitution_of_closed_below (closed_below_mono (nat.zero_le _) p)

theorem substitution_of_closed_below_gt: f.closed_below (n+1) → g.closed_below n → m ≤ n → f[m:=g].closed_below n :=
begin
  rw [closed_below_iff_uses_zero, closed_below_iff_uses_zero, closed_below_iff_uses_zero],
  intros hf hg hmn x hnx,
  simp [substitution_uses, trans hmn hnx,
    hf _ (nat.succ_le_succ hnx), hg _ hnx],
end

theorem substitution_zero_closed: f.closed_below 1 → g.closed → f[0:=g].closed :=
  λ hf hg, substitution_of_closed_below_gt hf hg (le_refl _)

theorem size_substitution (f: utlc) (n: ℕ) (g: utlc): f[n:=g].size = f.size + (f.uses n) * (g.size - 1) :=
begin
  induction f generalizing n g,
  { obtain h|h|h := nat.lt_trichotomy f n,
    simp [h, ne_of_lt h],
    simp [h, nat.add_comm 1, nat.sub_add_cancel (size_pos' g)],
    simp [lt_asymm h, ne_of_gt h] },
  { simp[f_ih, nat.add_right_comm _ 1 _] },
  { simp[f_ih_f, f_ih_g, ← nat.add_assoc, add_mul,
      nat.add_right_comm _ _ f_g.size,
      nat.add_right_comm _ 1 _] }
end

theorem shift_substitution_comm (f: utlc) (n: ℕ) (g: utlc): (f ↑¹ n)[n+1:=g] = (f ↑¹ (n+1))[n:=g] :=
begin
  induction f generalizing n g,
  { obtain h₀|h₀|h₀ := nat.lt_trichotomy f n,
    { simp[h₀, trans h₀ (nat.lt_succ_self _)] },
    { simp[h₀] },
    cases nat.eq_or_lt_of_le (nat.succ_le_of_lt h₀) with h₁ h₁;
    rw [nat.succ_eq_add_one] at h₁,
    { simp [←h₁, nat.add_assoc] },
    { simp [lt_asymm h₀, ne_of_gt h₀, lt_asymm h₁,
        show ¬ f + 1 < n, by linarith,
        show ¬ f + 1 = n, by linarith] } },
  { simp[f_ih] },
  { simp[f_ih_f, f_ih_g] }
end

theorem substitution_shift_lt {n m: ℕ} (hnm: n < m) (f g: utlc): (f ↑¹ (m+1))[n:=(g ↑¹ m)] = f[n:=g] ↑¹ m  :=
begin
  induction f generalizing n m g,
  { obtain hfn|hfn|hfn := nat.lt_trichotomy f n,
    { simp[hfn, trans hfn hnm, trans hfn (trans hnm (nat.lt_succ_self _))] },
    { simp[hfn, trans hnm (nat.lt_succ_self _)] },
    cases f,
    { revert hfn; simp },
    rw [nat.succ_eq_add_one] at *,
    by_cases f < m,
    { simp[h, lt_asymm hfn, ne_of_gt hfn, nat.sub_lt, @eq_comm _ (f - 1)] },
    { simp[h, lt_asymm hfn, ne_of_gt hfn,
        show ¬ f + 1 + 1 < n, by linarith,
        show f + 1 + 1 ≠ n, by linarith] } },
  { simp [f_ih _ (nat.succ_lt_succ hnm)] },
  { simp [f_ih_f _ hnm, f_ih_g _ hnm] }
end

theorem substitution_shift_ge {n m: ℕ} (hmn: m ≤ n) (f g: utlc): (f ↑¹ m)[n+1:=(g ↑¹ m)] = f[n:=g] ↑¹ m :=
begin
  induction f generalizing n m g,
  { obtain hfm|hfm|hfm := nat.lt_trichotomy f m,
    { simp [hfm, lt_of_lt_of_le hfm hmn, trans (lt_of_lt_of_le hfm hmn) (nat.lt_succ_self _)] },
    { cases lt_or_eq_of_le hmn with hmn hmn;
      { simp[hfm, hmn] } },
    obtain hfn|hfn|hfn := nat.lt_trichotomy f n,
    { simp[lt_asymm hfm, hfn] },
    { simp [lt_asymm hfm, ← hfn] },
    { cases f,
      { revert hfm, simp },
      rw [nat.succ_eq_add_one] at *,
      simp [lt_asymm hfm, ne_of_gt hfm, lt_asymm hfn, ne_of_gt hfn,
        show ¬ f < m, by linarith] } },
  { simp [f_ih _ (nat.succ_le_succ hmn)] },
  { simp [f_ih_f _ hmn, f_ih_g _ hmn] }
end

theorem substitution_shift_zero (f: utlc) (n: ℕ) (g: utlc): (f ↑¹ (n+1))[0:=(g ↑¹ n)] = f[0:=g] ↑¹ n :=
begin
  cases n,
  { rw [← substitution_shift_ge (nat.zero_le _)],
    simp [shift_substitution_comm] },
  apply substitution_shift_lt (nat.zero_lt_succ _)
end

theorem substitution_dist_lt {n m: ℕ} (hnm: n < m) (f g g': utlc):
  f[n:=g][m:=g'] = f[m+1:=g' ↑¹ n][n:=g[m:=g']] :=
begin
  induction f generalizing n m g g',
  { obtain hfn|hfn|hfn := nat.lt_trichotomy f n,
    { simp [hfn, trans hfn hnm, trans (trans hfn hnm) (nat.lt_succ_self _)] },
    { simp [hfn, trans hnm (nat.lt_succ_self _)] },
    cases f,
    { revert hfn, simp },
    rw [nat.succ_eq_add_one] at *,
    obtain hfm|hfm|hfm := nat.lt_trichotomy f m,
    { simp [lt_asymm hfn, ne_of_gt hfn, hfm] },
    { simp [lt_asymm hfn, ne_of_gt hfn, ← hfm] },
    { simp [lt_asymm hfn, ne_of_gt hfn, lt_asymm hfm, ne_of_gt hfm,
        show ¬ f < n, by linarith, show f ≠ n, by linarith ] } },
  { simp[f_ih _ _ (nat.succ_lt_succ hnm),
         substitution_shift_ge (nat.zero_le _)] },
  { simp[f_ih_f _ _ hnm, f_ih_g _ _ hnm] }
end

theorem substitution_dist_eq (f: utlc) (n: ℕ) (g g': utlc):
  f[n:=g][n:=g'] = f[n+1:=g' ↑¹ n][n:=g[n:=g']] :=
begin
  induction f generalizing n g g',
  {
    obtain hfn|hfn|hfn := nat.lt_trichotomy f n,
    { simp [hfn, trans hfn (nat.lt_succ_self _)] },
    { simp [hfn] },
    cases f,
    { revert hfn; simp },
    rw [nat.succ_eq_add_one] at *,
    cases eq_or_lt_of_le (nat.le_of_lt_succ hfn) with hfn₁ hfn₁,
    { simp [hfn₁] },
    { simp [lt_asymm hfn, ne_of_gt hfn, lt_asymm hfn₁, ne_of_gt hfn₁] } },
  { simp [f_ih, substitution_shift_ge (nat.zero_le _)] },
  { simp [f_ih_f, f_ih_g] }
end

end utlc
end lambda_calculus