/- Author: E.W.Ayers © 2019 -/

/- Expression zipper. -/
import .util .table
namespace expr

/-- Labels for each recursive argument of a constructor for `expr`. -/
@[derive decidable_eq]
inductive coord
|app_left     |app_right
|lam_var_type |lam_body
|pi_var_type  |pi_body
|elet_type    |elet_assignment |elet_body
def coord.code: coord → ℕ |coord.app_left := 0 |coord.app_right := 1 |coord.lam_var_type := 2 |coord.lam_body := 3 |coord.pi_var_type := 4 |coord.pi_body := 5 |coord.elet_type := 6 |coord.elet_assignment := 7 |coord.elet_body := 8
instance coord.has_lt : has_lt coord := ⟨λ x y, x.code < y.code⟩
instance coord.dec_lt : decidable_rel ((<) : coord → coord → Prop) := by apply_instance
/-- A list of `coord`s, specifying a position in an expression. The first coordinate says which way to go on the root.-/
def address := list coord
instance address.has_lt : has_lt address := show has_lt (list coord), by apply_instance
instance address.dec_lt : decidable_rel ((<) : address → address → Prop) := by apply_instance
instance address.has_append : has_append address := ⟨list.append⟩
/-- `is_below x y` is true when `∃ z, y ++ z = x` -/
def address.is_below : address → address → bool
|_ [] := tt -- everything is below root.
|[] _ := ff -- root is below nothing but itself.
|(h₁ :: t₁) (h₂ :: t₂) := h₁ = h₂ ∧ address.is_below t₁ t₂
infixr  ` ≺ `:50 := address.is_below
namespace zipper
    /-- A path is the part of the zipper that remembers the stuff above the zipper's cursor.-/
    @[derive decidable_eq]
    meta inductive path_entry
    |app_left        (left : unit) (right : expr) : path_entry
    |app_right       (left : expr) (right : unit) : path_entry
    |lam_var_type    (var_name : name) (bi : binder_info) (var_type : unit) (body : expr) : path_entry
    |lam_body        (var_name : name) (bi : binder_info) (var_type : expr) (body : unit) : path_entry
    |pi_var_type     (var_name : name) (bi : binder_info) (var_type : unit) (body : expr) : path_entry
    |pi_body         (var_name : name) (bi : binder_info) (var_type : expr) (body : unit) : path_entry
    |elet_type       (var_name : name) (type : unit) (assignment : expr)    (body : expr) : path_entry
    |elet_assignment (var_name : name) (type : expr) (assignment : unit)    (body : expr) : path_entry
    |elet_body       (var_name : name) (type : expr) (assignment : expr)    (body : unit) : path_entry
    /-- A context entry for the zipper's cursor.
    In the current implementation; as zippers traverse below lambdas,
    pis and elets, they don't replace de-Bruijn indices with local constants.
    -/
    @[derive decidable_eq]
    meta inductive context_entry
    |Hyp      (n : name) (bi : binder_info) (type : expr)  : context_entry
    |Assigned (n : name) (type : expr) (assignment : expr) : context_entry

    namespace path_entry
        meta def to_coord : path_entry → coord
        |(app_left _ _)            := coord.app_left
        |(app_right _ _)           := coord.app_right
        |(lam_var_type _ _ _ _)    := coord.lam_var_type
        |(lam_body _ _ _ _)        := coord.lam_body
        |(pi_var_type _ _ _ _)     := coord.pi_var_type
        |(pi_body _ _ _ _)         := coord.pi_body
        |(elet_type _ _ _ _)       := coord.elet_type
        |(elet_assignment _ _ _ _) := coord.elet_assignment
        |(elet_body _ _ _ _)       := coord.elet_body

        meta def to_address : list path_entry → address := list.map to_coord ∘ list.reverse
        open tactic
        meta def to_tactic_format : path_entry → tactic format
        |(app_left l r)            := (pure $ λ l r, l ++ " $ " ++ r) <*> pp l <*> pp r
        |(app_right l r)           := (pure $ λ l r, l ++ " $ " ++ r) <*> pp l <*> pp r
        |(lam_var_type n _ y b)    := (pure $ λ n y b, "λ " ++ n ++ " : " ++ y ++ ", " ++ b) <*> pp n <*> pp y <*> pp b
        |(lam_body n _ y b)        := (pure $ λ n y b, "λ " ++ n ++ " : " ++ y ++ ", " ++ b) <*> pp n <*> pp y <*> pp b
        |(pi_var_type n _ y b)     := (pure $ λ n y b, "Π " ++ n ++ " : " ++ y ++ ", " ++ b) <*> pp n <*> pp y <*> pp b
        |(pi_body n _ y b)         := (pure $ λ n y b, "Π " ++ n ++ " : " ++ y ++ ", " ++ b) <*> pp n <*> pp y <*> pp b
        |(elet_type n y a b)       := (pure $ λ n y a b, "let " ++ n ++ " : " ++ y ++ " := " ++ a ++ " in " ++ b) <*> pp n <*> pp y <*> pp a <*> pp b
        |(elet_assignment n y a b) := (pure $ λ n y a b, "let " ++ n ++ " : " ++ y ++ " := " ++ a ++ " in " ++ b) <*> pp n <*> pp y <*> pp a <*> pp b
        |(elet_body n y a b)       := (pure $ λ n y a b, "let " ++ n ++ " : " ++ y ++ " := " ++ a ++ " in " ++ b) <*> pp n <*> pp y <*> pp a <*> pp b
        meta instance has_to_tactic_format : has_to_tactic_format path_entry := ⟨to_tactic_format⟩
        meta def to_context_entry : path_entry → option context_entry
        |(lam_body  n bi y   b) := some $ context_entry.Hyp      n bi y
        |(pi_body   n bi y   b) := some $ context_entry.Hyp      n bi y
        |(elet_body n    y a b) := some $ context_entry.Assigned n    y a
        |_ := none
        meta def to_context : list path_entry → list context_entry
        := list.filter_map to_context_entry
    end path_entry

    namespace context_entry
        meta def type : context_entry → expr
        |(Hyp      _ _ y  ) := y
        |(Assigned _   y _) := y
        meta def name : context_entry → name
        |(Hyp      n _ _  ) := n
        |(Assigned n   _ _) := n
        meta def to_local : context_entry → tactic expr
        |(Hyp      n bi t  ) := tactic.mk_local' n bi t
        |(Assigned n    t _) := tactic.mk_local' n binder_info.default t
        meta def pexpr_pis_of_ctxt : list context_entry → pexpr → pexpr
        |[] e := to_pexpr e
        |((context_entry.Hyp n bi y) :: rest) e :=
            pexpr_pis_of_ctxt rest $ @expr.pi ff n bi (to_pexpr y) $ e
        |((context_entry.Assigned n y a) :: rest) e :=
            pexpr_pis_of_ctxt rest $ expr.elet n (to_pexpr y) (to_pexpr a) $ e
        -- meta def hyps_of_telescope : telescope → list context_entry
        -- := list.map (λ ⟨n,bi,y⟩, context_entry.Hyp n bi y)
    end context_entry
end zipper
/--
A zipper over expressions. You can think of this as being like a 'cursor' that can move around an `expr`.
It does not replace bound variables with local constants, but instead maintains its own 'mini-context' of the binders that it is under.

Reference: [Functional Pearl - The Zipper](https://www.st.cs.uni-saarland.de/edu/seminare/2005/advanced-fp/docs/huet-zipper.pdf)
 -/
@[derive decidable_eq]
meta structure zipper :=
(path : list zipper.path_entry)
(current : expr)

/-- Result type of calling `zipper.down`.  -/
@[derive decidable_eq]
meta inductive down_result
|terminal : down_result
|app  (left : zipper) (right : zipper) : down_result
| lam (var_name : name) (bi : binder_info) (var_type : zipper) (body : zipper) : down_result
|  pi (var_name : name) (bi : binder_info) (var_type : zipper) (body : zipper) : down_result
|elet (var_name : name) (type : zipper) (assignment : zipper) (body : zipper) : down_result

meta def down_result.children : down_result → list zipper
|(down_result.terminal) := []
|(down_result.app l r) := [l,r]
|(down_result.lam n bi vt b) := [vt,b]
|(down_result.pi n bi vt b) := [vt,b]
|(down_result.elet n t a b) := [t,a,b]

namespace zipper
    open path_entry
    /--Move the cursor down the expression tree.-/
    meta def down : zipper → down_result
    |⟨p, expr.app f a⟩ :=
        down_result.app
            ⟨app_left  () a  :: p, f⟩
            ⟨app_right f  () :: p, a⟩
    |⟨p, expr.lam n bi y b⟩ :=
        down_result.lam n bi
            ⟨lam_var_type n bi () b  :: p, y⟩
            ⟨lam_body     n bi y  () :: p, b⟩
    |⟨p, expr.pi  n bi y b⟩ :=
        down_result.pi n bi
            ⟨pi_var_type  n bi () b  :: p,  y⟩
            ⟨pi_body      n bi y  () :: p,  b⟩
    |⟨p, expr.elet n t a b⟩ :=
        down_result.elet n
            ⟨elet_type n () a b :: p,  t⟩
            ⟨elet_assignment n t () b :: p,  a⟩
            ⟨elet_body n t a () :: p, b⟩
    |⟨p,e⟩ := down_result.terminal
    meta def children : zipper → list zipper := down_result.children ∘ down

    meta def down_coord : coord → zipper → option zipper
    |(coord.app_left)        ⟨p,expr.app f a⟩      := some ⟨app_left  () a           :: p, f⟩
    |(coord.app_right)       ⟨p,expr.app f a⟩      := some ⟨app_right f ()           :: p, a⟩
    |(coord.lam_var_type)    ⟨p,expr.lam n bi y b⟩ := some ⟨lam_var_type n bi () b   :: p, y⟩
    |(coord.lam_body)        ⟨p,expr.lam n bi y b⟩ := some ⟨lam_body     n bi y ()   :: p, b⟩
    |(coord.pi_var_type)     ⟨p,expr.pi n bi y b⟩  := some ⟨pi_var_type  n bi () b   :: p, y⟩
    |(coord.pi_body)         ⟨p,expr.pi n bi y b⟩  := some ⟨pi_body      n bi y ()   :: p, b⟩
    |(coord.elet_type)       ⟨p,expr.elet n y a b⟩ := some ⟨elet_type       n () a b :: p, y⟩
    |(coord.elet_assignment) ⟨p,expr.elet n y a b⟩ := some ⟨elet_assignment n y () b :: p, a⟩
    |(coord.elet_body)       ⟨p,expr.elet n y a b⟩ := some ⟨elet_body       n y a () :: p, b⟩
    |_ _ := none

    /-- Pop the cursor up the expression tree. If we are already at the top, returns `none`. -/
    meta def up : zipper → option zipper
    |⟨[],                            e⟩ := none
    |⟨app_left  () a           :: p, f⟩ := some $ zipper.mk p $ expr.app f a
    |⟨app_right f  ()          :: p, a⟩ := some $ zipper.mk p $ expr.app f a
    |⟨lam_var_type   n bi _ b  :: p, e⟩ := some $ zipper.mk p $ expr.lam n bi e b
    |⟨lam_body       n bi y _  :: p, e⟩ := some $ zipper.mk p $ expr.lam n bi y e
    |⟨pi_var_type    n bi _ b  :: p, e⟩ := some $ zipper.mk p $ expr.pi  n bi e b
    |⟨pi_body        n bi y _  :: p, e⟩ := some $ zipper.mk p $ expr.pi  n bi y e
    |⟨elet_type       n _ a b  :: p, e⟩ := some $ zipper.mk p $ expr.elet n e a b
    |⟨elet_assignment n t _ b  :: p, e⟩ := some $ zipper.mk p $ expr.elet n t e b
    |⟨elet_body       n t a _  :: p, e⟩ := some $ zipper.mk p $ expr.elet n t a e
    meta def is_top : zipper → bool := list.empty ∘ path
    meta def top := option.repeat up
    meta def down_app_left : zipper → option zipper := down_coord coord.app_left
    meta def down_app_right : zipper → option zipper := down_coord coord.app_right

    meta def down_body : zipper → option zipper := λ z,
        match down z with
        |down_result.pi   _ _ _ b := some b
        |down_result.lam  _ _ _ b := some b
        |down_result.elet _ _ _ b := some b
        |_ := none
        end
    meta def down_var_type : zipper → option zipper := λ z,
        match down z with
        |down_result.pi   _ _ y b := some y
        |down_result.lam  _ _ y b := some y
        |down_result.elet _ y _ b := some y
        |_ := none
        end
    /-- Move the cursor down according to the given address.
    If the zipper has the wrong structure then return none.-/
    meta def down_address : address → zipper → option zipper
    |[]     z := some z
    |(h::t) z := down_coord h z >>= down_address t

    meta def unzip : zipper → expr := λ z, option.rec_on (up z) (current z) (unzip)
    meta def zip : expr → zipper := λ e, zipper.mk [] e
    meta instance : has_coe expr zipper := ⟨zip⟩
    meta def set_current : expr → zipper → zipper
    |e ⟨p,_⟩ := ⟨p,e⟩
    /-- Map the current subexpression. -/
    meta def map : (expr → expr) → zipper → zipper
    |f ⟨p,e⟩ := ⟨p,f e⟩
    meta def mmap {T} [monad T] : (expr → T expr) → zipper → T zipper
    |f ⟨p,e⟩ := zipper.mk p <$> f e
    meta def address : zipper → address := to_address ∘ path
    meta def ctxt : zipper → list context_entry := to_context ∘ path
    /-- The number of binders above the cursor. -/
    meta def binder_depth : zipper → ℕ := list.length ∘ ctxt
    /-- Replace the current subexpression and unzip. -/
    meta def unzip_with : expr → zipper → expr := λ e z, unzip $ z.set_current e
    meta def is_var : zipper → bool := expr.is_var ∘ current
    meta def is_constant : zipper → bool := expr.is_constant ∘ current
    /--True when the current expression does not contain local constants -/
    meta def no_local_consts : zipper → bool := list.empty ∘ expr.list_local_consts ∘ current
    meta def no_local_const_terms : zipper → tactic bool
    := λ z, list.empty <$> (expr.list_local_const_terms $ current $ z)
    meta def is_local_constant : zipper → bool := expr.is_local_constant ∘ current
    meta def is_mvar : zipper → bool := expr.is_mvar ∘ current
    meta def is_terminal : zipper → bool := λ z, z.down = down_result.terminal
    /--Infer the type of the subexpression at the cursor position. -/
    meta def infer_type : zipper → tactic expr := λ z, do
            ⟨ins,lcs⟩ ← list.mfoldl (λ ct s, do
                l ← context_entry.to_local s,
                pure $ (expr.instantiate_var ct.1 l, l::ct.2)
            ) (z.current,([] : list expr)) z.ctxt,
            y ← tactic.infer_type ins,
            let y := lcs.foldl expr.abstract y,
            pure y
    meta instance : has_to_tactic_format zipper := ⟨λ z, do
     whole ← tactic.pp $ z.unzip_with `(()),
     current ← tactic.pp z.current,
     pure $ format.highlight current format.color.blue ++ " in " ++ whole
     ⟩
    universes u v
    /-- Helper lemma for `mk_congr` -/
    lemma eq_cc {α : Type u} {β : Type v} (F : α → β) (a₁: α)
    :  ∀ a₂ : α, a₁ = a₂ → F a₁ = F a₂
    := @eq.rec α a₁ (λ a, F a₁ = F a) rfl
    open tactic
    /-- Given a zipper, makes a congruence lemma at the zipper's position.
    [NOTE] Assumes that the zipper is not inside any binders (for now). -/
    meta def mk_congr (z : zipper) : tactic expr := do
        when (z.binder_depth ≠ 0) (tactic.fail "Not implemented: congruences inside a binder"),
        let lhs := z.current,
        let lhs' := z.unzip,
        T ← tactic.infer_type lhs,
        target ← to_expr $ ```(∀ X : %%(T), (%%lhs = X) → %%lhs' = %%(z.unzip_with $ expr.var 1)),
        tactic.fabricate (some target) (do
            -- get_goals >>= list.mmap infer_type >>= trace,
            refine ```(@eq.rec _ %%lhs (λ X, %%(lhs') = %%(z.unzip_with $ expr.var 0)) rfl),
            -- get_goals >>= list.mmap infer_type >>= trace,
            pure ()
        )
    /-- Replace the current expression with an unbound deBruijn variable. -/
    meta def unzip_free : zipper → expr := λ z, z.unzip_with $ expr.var z.binder_depth
    /-- `apply_congr (rhs,pf) z` takes the given `%%pf : %%z.current = %%rhs` and makes a congruence lemma using the given zipper.  -/
    meta def apply_congr : (expr × expr) → zipper → tactic (expr × expr) := λ ⟨rhs,pf⟩ z, do
        if z.is_top then pure ⟨rhs,pf⟩ else do
        let lhs := z.current,
        T ← tactic.infer_type lhs,
        let lhs' := z.unzip,
        let rhs' := unzip_with rhs z,
        target ← to_expr $ ```(%%lhs' = %%rhs'),
        -- pp target >>= λ m, trace $ ("target: ":format) ++ m,
        motive ← to_expr $ @expr.lam ff `X binder_info.default (to_pexpr T) $ ```(%%lhs' = %%(z.unzip_with $ expr.var z.binder_depth)),
        -- pp motive >>= λ m, trace $ ("motive: ":format) ++ m,
        pf' ← tactic.fabricate (some target) (do
            -- trace_state,
            refine ```(@eq.rec %%T %%lhs %%motive rfl %%rhs %%pf),
            all_goals $ try $ (apply_instance <|> assumption)
        ),
        pure (rhs',pf')

    /-- Produce a conversion that uses the given conversion at the zipper's subexpression.-/
    meta def apply_conv : conv unit → zipper → conv unit := λ cnv z, do
        let lhs := z.current,
        T ← tactic.infer_type lhs,
        rhs ← mk_meta_var T,
        let lhs' := z.unzip,
        target ← to_expr $ ```(%%lhs' = %%(z.unzip_with rhs)),
        rewrite_target target,
        refine ```(@eq.rec %%T %%lhs (λ X, %%lhs' = z.unzip_with $ expr.var 0) rfl %%rhs _),
        cnv

    /-- A proper argument is one who is not implicit or a proposition.
        Ie, anything which the user would see when writing down the term. -/
    private meta def is_proper (p : param_info) : bool :=
        ¬(param_info.is_implicit p || param_info.is_inst_implicit  p || param_info.is_prop p)

    meta def is_type (z : zipper) : tactic bool := expr.is_sort <$> tactic.infer_type z.current

    /-- Take a zipper where the current expression is a function application,
        and return zippers over all of the non-implicit, non-prop arguments. -/
    meta def down_proper (z : zipper) : tactic (zipper × list zipper) := do
        let c := z.current,
        let f := expr.get_app_fn c,
        let f_name := expr.as_name f,
        -- if it is a numeral then don't expand it.
        if f_name = `bit0 ∨ f_name = `bit1 then pure (z,[]) else do
        let args := expr.get_app_args c,
        params ← (fun_info.params <$> tactic.get_fun_info f (args.length)) <|> pure [],
        let params := list.reverse params,
        ⟨zippers, fz⟩ ← params.mfoldl (λ acc p, do
                let (⟨zippers,z⟩ : (list zipper) × zipper) := acc,
                z' ← down_app_left z,
                if is_proper p then do
                    zr ← down_app_right z,
                    --t ← is_type zr,
                    --if t then pure (zippers,z') else
                    pure (zr::zippers,z')
                else pure (zippers, z')
            )
            (([] : list zipper), z),
        pure (fz,zippers)

    meta def fold {α} (f : α → zipper → α) : α → zipper → α
    | a z := z.children.foldl fold $ f a z
    meta def mfold {T} [monad T] {α} (f : α → zipper → T α) : α → zipper → T α
    | a z := do a ← f a z, z.children.mfoldl mfold a

    /-- Traverse zipper.current, only exploring explicit, non-Prop arguments.
        If `f` fails, then that branch is skipped. -/
    meta def traverse_proper {α} (f : α →  zipper → tactic α) : α → zipper → tactic α
    |a z := (do
        a ← f a z,
        (_,children) ← down_proper z,
        children.mfoldl traverse_proper a)
        <|> pure a

    /-- `minimal_monotone p z` finds the smallest proper subexpressions of the zipper such that
        `p` doesn't fail.
        [NOTE] It assumes that if `p e` fails, then all of `e`s subexpressions will fail too. -/
    meta def minimal_monotone {α} (p : zipper → tactic α) : zipper → tactic (list α)
    |z := (do
            a ← p z,
            (_,children) ← down_proper z,
            kids ← list.join <$> list.mmap minimal_monotone children,
            pure $ list.cases_on kids [a] (λ _ _,kids)
        )
        <|>  pure []

    /-- `maximal_monotone p z`: Find the largest proper subexpressions of the zipper such that
        `p` doesn't fail.
        [NOTE] It assumes that if `p e` fails, then all of `e`s subexpressions will fail too. -/
    meta def maximal_monotone {α} (p : zipper → tactic α) : zipper → tactic (list α)
    |z := (do a ← p z,  pure [a]) <|> do
            (f,children) ← down_proper z,
            children ← pure $ if is_local_constant f && ¬children.empty then f :: children else children,
            kids ← list.join <$> list.mmap maximal_monotone children,
            pure $ kids
    /-- `find_occurences z e` finds subexpressions of `z` which non-trivially unify with `e`. -/
    meta def find_occurences : zipper → expr → tactic (list zipper) := λ E e, do
        rs ← maximal_monotone (λ z,
            if z.is_mvar || z.is_constant then failure
            else tactic.hypothetically' (unify e z.current transparency.none) *> pure z
        ) E,
        pure rs

    meta def has_occurences : zipper → expr → tactic bool
    := λ z e, (bnot ∘ list.empty) <$> find_occurences z e

    meta def smallest_absent_subterms_aux (l : expr)
        (filter : zipper → tactic bool := combinator.K $ pure tt)
        : list expr.address  → zipper → tactic (list expr.address × list (ℕ × zipper))
    |used z := do
        filt ← filter z,
        if ¬ filt then pure (used, []) else do
        occs ← find_occurences l z.current,
        o ← pure $ list.find (λ o, bnot $ list.any used $ λ x, zipper.address o ≺ x) occs,
        match o with
        |none := do -- z.current is not present, descend.
            (_,children) ← down_proper z,
            (used,zs) ← list.mfoldl (λ p child, do
                (used,zs') ← smallest_absent_subterms_aux (prod.fst p) child,
                pure (used,zs' ++ p.2)
            ) (used,[]) children,
            if zs.empty then pure $ (used,[(occs.length + 1,z)]) else pure $ (used,zs)
        |some o :=
            -- z.current is present on the lhs
            -- so now we need to add `o` to the used list so that later matches can't use it.
            pure $ (used.insert o.address,[])
        end

    /-- find subterms of RHS that do not appear on LHS. It will also count when occurrences have been used.
        So for example, ``smallest_absent_subterms `(a * b + b * a) `(a * b + a * b)`` will return `[(2,a * b)] because
        `a * b` occurs once in the LHS but twice in the RHS.
    -/
    meta def smallest_absent_subterms (lhs : expr) (rhs : zipper) :=
        prod.snd <$> smallest_absent_subterms_aux lhs (λ z, bnot <$> no_local_const_terms z) [] rhs

    meta def smallest_absent_composite_subterms (lhs : expr) (rhs : zipper) :=
        prod.snd
            <$> smallest_absent_subterms_aux lhs
                (λ s, do
                    hlcst ← bnot <$> no_local_const_terms s,
                    is_term ← expr.is_term s.current,
                     pure $ hlcst && is_term && expr.is_composite s.current)
                [] rhs

    /--`lowest_uncommon_subterms l z` finds the smallest subterms of z that are not a subterm of `l`. Subterms must include a local_const -/
    meta def lowest_uncommon_subterms (l : expr) (z : zipper) :=
        minimal_monotone (λ z,
            if z.is_mvar || z.is_constant || z.no_local_consts then failure else do
            --let o := expr.occurs z.current l,
            matches ← zipper.maximal_monotone (λ rz, (tactic.hypothetically' $ unify z.current rz.current) ) $ zipper.zip l,
            -- trace_m "lus: " $ (z,l,o, matches),
            if ¬ matches.empty then failure else pure z
        ) z

    meta def largest_common_subterms (z₁ z₂ : zipper): tactic (list zipper) :=
        list.join <$> z₁.maximal_monotone (λ z₁,
            if z₁.is_mvar then failure else do
            ocs ← find_occurences (z₂) z₁.current,
            if ocs.empty then failure else pure ocs
        )

    private meta def count_symbols_aux : table expr → zipper → tactic (table expr)
    | acc z := do
        (f,zs) ← down_proper z,
        if zipper.is_mvar f then pure acc else
        zs.mfoldl count_symbols_aux $ table.insert f.current acc

    meta def count_symbols : expr → tactic (table expr) := count_symbols_aux ∅ ∘ zip

    meta def does_unify (e : expr) : zipper → tactic unit
    | z := if z.is_mvar then failure else
        (tactic.hypothetically' $ unify e z.current transparency.none ff)

    meta def find_subterms (e : expr) : zipper → tactic (list zipper)
    := traverse_proper (λ acc z, (does_unify e z *> pure (z::acc)) <|> pure acc) []

    meta def has_single_subterm (e : expr) : zipper → tactic (zipper)
    := λ z, do [x] ← find_subterms e z, pure x

    meta def count_subterms (e : expr) : zipper → tactic ℕ
    := λ z, do xs ← find_subterms e z, pure $ list.length xs

    meta def find_non_unify_subterm (e : expr) : zipper → tactic zipper
    |z :=
        if e = z.current then pure z else do
        (_,zs) ← down_proper z,
        list.mfirst find_non_unify_subterm zs

    meta def find_subterm (e : expr) : zipper → tactic zipper
    |z :=
        (does_unify e z *> pure z)
        <|> do
            (_,zs) ← down_proper z,
            list.mfirst find_subterm zs

    meta def distance_to_subterm_down (e : expr) : zipper → nat → tactic nat
    |z d :=
        if z.is_mvar then failure else
        (tactic.hypothetically' $ (do
            unify e z.current,  pure d
        ))
        <|> (do
            -- tactic.trace_m "dtsd: " $ z,
            (_,zs) ← down_proper z,
            list.mfirst (λ iz : ℕ × zipper, distance_to_subterm_down iz.2 $ iz.1 + d + 1)
            $ list.with_indices zs
        )

    meta def is_app_right : zipper → bool
    |⟨(app_right _ _)::t,_⟩ := tt
    |_ := ff

    meta def right : zipper → option zipper
    |z := if is_app_right z then up z >>= right else up z >>= down_app_right

    meta def distance_to_subterm_up (e : expr) : ℕ → zipper → tactic ℕ
    |d z :=
        if is_app_right z then up z >>= distance_to_subterm_up (d+1) else do
        -- tactic.trace_m "dtsu1: " $ z,
        z ← up z >>= lift down_app_right,
        -- tactic.trace_m "dtsu2: " $ z,
        distance_to_subterm_down e z (d+1)
        <|> distance_to_subterm_up (d+1) z

    meta def get_distance (outer : expr) (l : expr) (r : expr) : tactic ℕ := do
        outer ← instantiate_mvars outer,
        first ← find_subterm l outer,
        -- tactic.trace_m "gd: " $ first,
        distance_to_subterm_up r 0 first

    meta def get_proper_children (e : expr) : tactic (list expr) := do
        e ← instantiate_mvars e,
        (list.map current <$> prod.snd <$> (down_proper $ zip e)) <|> pure []
    meta def get_smallest_complex_subterms (z : zipper) : tactic (list zipper) := do
        minimal_monotone (λ z, do ⟨_,[]⟩ ← down_proper z | failure, pure z) z

    meta def instantiate_mvars : zipper → tactic zipper
    |z := do
        let a := address z,
        let e := unzip z,
        e ← tactic.instantiate_mvars e,
        z ← down_address a e,
        pure z

    /-- Returns true when everything in the zippers except the cursor terms are equal. -/
    meta def above_equal : zipper → zipper → tactic bool
    |z₁ z₂ := do
          list.meq_by (λ x y, pure $ x = y) z₁.path z₂.path

end zipper
end expr


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import data.fintype.prod
import data.fintype.sigma
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.finite
import category_theory.limits.constructions.finite_products_of_binary_products
import category_theory.limits.constructions.equalizers
import category_theory.limits.constructions.binary_products

/-!
# Constructing limits from products and equalizers.

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

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

open category_theory
open opposite

namespace category_theory.limits

universes w v v₂ u u₂
variables {C : Type u} [category.{v} C]

variables {J : Type w} [small_category J]

-- We hide the "implementation details" inside a namespace
namespace has_limit_of_has_products_of_has_equalizers

variables {F : J ⥤ C}
          {c₁ : fan F.obj}
          {c₂ : fan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2)}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), s ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.1⟩ ≫ F.map f.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), t ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.2⟩)
          (i : fork s t)

include hs ht
/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
@[simps]
def build_limit : cone F :=
{ X := i.X,
  π :=
  { app := λ j, i.ι ≫ c₁.π.app ⟨_⟩,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.id_comp, category.assoc, ← hs ⟨⟨_, _⟩, f⟩, i.condition_assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) :
  is_limit (build_limit s t hs ht i) :=
{ lift := λ q,
  begin
    refine hi.lift (fork.of_ι _ _),
    { refine t₁.lift (fan.mk _ (λ j, _)),
      apply q.π.app j },
    { apply t₂.hom_ext,
      intro j, discrete_cases,
      simp [hs, ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.equalizer_ext (t₁.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_limit_of_has_products_of_has_equalizers

open has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers,
we can construct a limit cone for `F`.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
noncomputable
def limit_cone_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : limit_cone F :=
{ cone := _,
  is_limit :=
    build_is_limit
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨_⟩ ≫ F.map f.2))
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨f.1.2⟩))
      (by simp)
      (by simp)
      (limit.is_limit _)
      (limit.is_limit _)
      (limit.is_limit _) }

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
lemma has_limit_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : has_limit F :=
has_limit.mk (limit_cone_of_equalizer_and_product F)

/-- A limit can be realised as a subobject of a product. -/
noncomputable
def limit_subobject_product [has_limits_of_size.{w w} C] (F : J ⥤ C) :
  limit F ⟶ ∏ (λ j, F.obj j) :=
(limit.iso_limit_cone (limit_cone_of_equalizer_and_product F)).hom ≫ equalizer.ι _ _

instance limit_subobject_product_mono [has_limits_of_size.{w w} C] (F : J ⥤ C) :
  mono (limit_subobject_product F) :=
mono_comp _ _

/--
Any category with products and equalizers has all limits.

See <https://stacks.math.columbia.edu/tag/002N>.
-/
lemma has_limits_of_has_equalizers_and_products
  [has_products.{w} C] [has_equalizers C] : has_limits_of_size.{w w} C :=
{ has_limits_of_shape := λ J 𝒥,
  { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F } }

/--
Any category with finite products and equalizers has all finite limits.

See <https://stacks.math.columbia.edu/tag/002O>.
-/
lemma has_finite_limits_of_has_equalizers_and_finite_products
  [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
⟨λ J _ _, { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F }⟩

variables {D : Type u₂} [category.{v₂} D]
noncomputable theory

section

variables [has_limits_of_shape (discrete J) C]
          [has_limits_of_shape (discrete (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_equalizers C]
variables (G : C ⥤ D)
          [preserves_limits_of_shape walking_parallel_pair G]
          [preserves_limits_of_shape (discrete.{w} J) G]
          [preserves_limits_of_shape (discrete.{w} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product :
  preserves_limits_of_shape J G :=
{ preserves_limit := λ K,
  begin
    let P := ∏ K.obj,
    let Q := ∏ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.2),
    let s : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨_⟩ ≫ K.map f.2),
    let t : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨f.1.2⟩),
    let I := equalizer s t,
    let i : I ⟶ P := equalizer.ι s t,
    apply preserves_limit_of_preserves_limit_cone
      (build_is_limit s t (by simp) (by simp)
        (limit.is_limit _)
        (limit.is_limit _)
        (limit.is_limit _)),
    refine is_limit.of_iso_limit (build_is_limit _ _ _ _ _ _ _) _,
    { exact fan.mk _ (λ j, G.map (pi.π _ j)) },
    { exact fan.mk (G.obj Q) (λ f, G.map (pi.π _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { apply fork.of_ι (G.map i) _,
      simp only [← G.map_comp, equalizer.condition] },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_fork_map_of_is_limit,
      apply equalizer_is_equalizer },
    refine cones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products
  [has_equalizers C] [has_finite_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ (J : Type) [fintype J], preserves_limits_of_shape (discrete J) G] :
  preserves_finite_limits G :=
⟨λ _ _ _, by exactI preserves_limit_of_preserves_equalizers_and_product G⟩

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products
  [has_equalizers C] [has_products.{w} C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair G]
  [∀ J, preserves_limits_of_shape (discrete.{w} J) G] :
preserves_limits_of_size.{w w} G :=
{ preserves_limits_of_shape := λ J 𝒥,
  by exactI preserves_limit_of_preserves_equalizers_and_product G }

lemma has_finite_limits_of_has_terminal_and_pullbacks [has_terminal C] [has_pullbacks C] :
  has_finite_limits C :=
@@has_finite_limits_of_has_equalizers_and_finite_products _
  (@@has_finite_products_of_has_binary_and_terminal _
    (has_binary_products_of_has_terminal_and_pullbacks C) infer_instance)
  (@@has_equalizers_of_has_pullbacks_and_binary_products _
    (has_binary_products_of_has_terminal_and_pullbacks C) infer_instance)

/-- If G preserves terminal objects and pullbacks, it preserves all finite limits. -/
def preserves_finite_limits_of_preserves_terminal_and_pullbacks
  [has_terminal C] [has_pullbacks C] (G : C ⥤ D)
  [preserves_limits_of_shape (discrete.{0} pempty) G]
  [preserves_limits_of_shape walking_cospan G] :
preserves_finite_limits G :=
begin
  haveI : has_finite_limits C := has_finite_limits_of_has_terminal_and_pullbacks,
  haveI : preserves_limits_of_shape (discrete walking_pair) G :=
    preserves_binary_products_of_preserves_terminal_and_pullbacks G,
  exact @@preserves_finite_limits_of_preserves_equalizers_and_finite_products _ _ _ _ G
    (preserves_equalizers_of_preserves_pullbacks_and_binary_products G)
    (preserves_finite_products_of_preserves_binary_and_terminal G),
end

/-!
We now dualize the above constructions, resorting to copy-paste.
-/

-- We hide the "implementation details" inside a namespace
namespace has_colimit_of_has_coproducts_of_has_coequalizers

variables {F : J ⥤ C}
          {c₁ : cofan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1)}
          {c₂ : cofan F.obj}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ s = F.map f.2 ≫ c₂.ι.app ⟨f.1.2⟩)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ t = c₂.ι.app ⟨f.1.1⟩)
          (i : cofork s t)

include hs ht
/--
(Implementation) Given the appropriate coproduct and coequalizer cocones,
build the cocone for `F` which is colimiting if the given cocones are also.
-/
@[simps]
def build_colimit : cocone F :=
{ X := i.X,
  ι :=
  { app := λ j, c₂.ι.app ⟨_⟩ ≫ i.π,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.comp_id, ←reassoc_of (hs ⟨⟨_, _⟩, f⟩), i.condition, ←category.assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cocone constructed in `build_colimit` is colimiting,
provided the cocones used in its construction are.
-/
def build_is_colimit (t₁ : is_colimit c₁) (t₂ : is_colimit c₂) (hi : is_colimit i) :
  is_colimit (build_colimit s t hs ht i) :=
{ desc := λ q,
  begin
    refine hi.desc (cofork.of_π _ _),
    { refine t₂.desc (cofan.mk _ (λ j, _)),
      apply q.ι.app j },
    { apply t₁.hom_ext,
      intro j, discrete_cases,
      simp [reassoc_of hs, reassoc_of ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.coequalizer_ext (t₂.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_colimit_of_has_coproducts_of_has_coequalizers

open has_colimit_of_has_coproducts_of_has_coequalizers

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we can construct a colimit cocone for `F`.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
noncomputable
def colimit_cocone_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : colimit_cocone F :=
{ cocone := _,
  is_colimit :=
    build_is_colimit
      (sigma.desc (λ f, F.map f.2 ≫ colimit.ι (discrete.functor F.obj) ⟨f.1.2⟩))
      (sigma.desc (λ f, colimit.ι (discrete.functor F.obj) ⟨f.1.1⟩))
      (by simp)
      (by simp)
      (colimit.is_colimit _)
      (colimit.is_colimit _)
      (colimit.is_colimit _) }

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we know a colimit of `F` exists.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
lemma has_colimit_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : has_colimit F :=
has_colimit.mk (colimit_cocone_of_coequalizer_and_coproduct F)

/-- A colimit can be realised as a quotient of a coproduct. -/
noncomputable
def colimit_quotient_coproduct [has_colimits_of_size.{w w} C] (F : J ⥤ C) :
  ∐ (λ j, F.obj j) ⟶ colimit F :=
coequalizer.π _ _ ≫ (colimit.iso_colimit_cocone (colimit_cocone_of_coequalizer_and_coproduct F)).inv

instance colimit_quotient_coproduct_epi [has_colimits_of_size.{w w} C] (F : J ⥤ C) :
  epi (colimit_quotient_coproduct F) :=
epi_comp _ _

/--
Any category with coproducts and coequalizers has all colimits.

See <https://stacks.math.columbia.edu/tag/002P>.
-/
lemma has_colimits_of_has_coequalizers_and_coproducts
  [has_coproducts.{w} C] [has_coequalizers C] : has_colimits_of_size.{w w} C :=
{ has_colimits_of_shape := λ J 𝒥,
  { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F } }

/--
Any category with finite coproducts and coequalizers has all finite colimits.

See <https://stacks.math.columbia.edu/tag/002Q>.
-/
lemma has_finite_colimits_of_has_coequalizers_and_finite_coproducts
  [has_finite_coproducts C] [has_coequalizers C] : has_finite_colimits C :=
⟨λ J _ _, { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F }⟩

noncomputable theory

section

variables [has_colimits_of_shape (discrete.{w} J) C]
          [has_colimits_of_shape (discrete.{w} (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_coequalizers C]
variables (G : C ⥤ D)
          [preserves_colimits_of_shape walking_parallel_pair G]
          [preserves_colimits_of_shape (discrete.{w} J) G]
          [preserves_colimits_of_shape (discrete.{w} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves coequalizers and the appropriate coproducts, it preserves colimits. -/
def preserves_colimit_of_preserves_coequalizers_and_coproduct :
  preserves_colimits_of_shape J G :=
{ preserves_colimit := λ K,
  begin
    let P := ∐ K.obj,
    let Q := ∐ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.1),
    let s : Q ⟶ P := sigma.desc (λ f, K.map f.2 ≫ colimit.ι (discrete.functor K.obj) ⟨_⟩),
    let t : Q ⟶ P := sigma.desc (λ f, colimit.ι (discrete.functor K.obj) ⟨f.1.1⟩),
    let I := coequalizer s t,
    let i : P ⟶ I := coequalizer.π s t,
    apply preserves_colimit_of_preserves_colimit_cocone
      (build_is_colimit s t (by simp) (by simp)
        (colimit.is_colimit _)
        (colimit.is_colimit _)
        (colimit.is_colimit _)),
    refine is_colimit.of_iso_colimit (build_is_colimit _ _ _ _ _ _ _) _,
    { exact cofan.mk (G.obj Q) (λ j, G.map (sigma.ι _ j)) },
    { exact cofan.mk _ (λ f, G.map (sigma.ι _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { apply cofork.of_π (G.map i) _,
      simp only [← G.map_comp, coequalizer.condition] },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_cofork_map_of_is_colimit,
      apply coequalizer_is_coequalizer },
    refine cocones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves coequalizers and finite coproducts, it preserves finite colimits. -/
def preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts
  [has_coequalizers C] [has_finite_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J [fintype J], preserves_colimits_of_shape (discrete.{0} J) G] :
  preserves_finite_colimits G :=
⟨λ _ _ _, by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G⟩

/-- If G preserves coequalizers and coproducts, it preserves all colimits. -/
def preserves_colimits_of_preserves_coequalizers_and_coproducts
  [has_coequalizers C] [has_coproducts.{w} C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair G]
  [∀ J, preserves_colimits_of_shape (discrete.{w} J) G] :
preserves_colimits_of_size.{w} G :=
{ preserves_colimits_of_shape := λ J 𝒥,
  by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G }

lemma has_finite_colimits_of_has_initial_and_pushouts [has_initial C] [has_pushouts C] :
  has_finite_colimits C :=
@@has_finite_colimits_of_has_coequalizers_and_finite_coproducts _
  (@@has_finite_coproducts_of_has_binary_and_initial _
    (has_binary_coproducts_of_has_initial_and_pushouts C) infer_instance)
  (@@has_coequalizers_of_has_pushouts_and_binary_coproducts _
    (has_binary_coproducts_of_has_initial_and_pushouts C) infer_instance)

/-- If G preserves initial objects and pushouts, it preserves all finite colimits. -/
def preserves_finite_colimits_of_preserves_initial_and_pushouts
  [has_initial C] [has_pushouts C] (G : C ⥤ D)
  [preserves_colimits_of_shape (discrete.{0} pempty) G]
  [preserves_colimits_of_shape walking_span G] :
preserves_finite_colimits G :=
begin
  haveI : has_finite_colimits C := has_finite_colimits_of_has_initial_and_pushouts,
  haveI : preserves_colimits_of_shape (discrete walking_pair) G :=
    preserves_binary_coproducts_of_preserves_initial_and_pushouts G,
  exact @@preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts _ _ _ _ G
    (preserves_coequalizers_of_preserves_pushouts_and_binary_coproducts G)
    (preserves_finite_coproducts_of_preserves_binary_and_initial G),
end

end category_theory.limits


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

import FxyLang.Reasoning.Defs

theorem State.doneLoop : done c k v^[n] = done c k v := by
  induction n with
  | zero      => rw [stepN]
  | succ _ hi => rw [stepN, step]; exact hi

theorem State.errorLoop : error c k t v^[n] = error c k t v := by
  induction n with
  | zero      => rw [stepN]
  | succ _ hi => rw [stepN, step]; exact hi

open Lean.Parser.Tactic in
syntax "step_induction " ident (" using " term,+)?
  (" with " simpLemma)? : tactic

open Lean.Elab.Tactic in
set_option hygiene false in
elab_rules : tactic
  | `(tactic| step_induction $hi $[using $ts,*]? $[with $h]?) => do
    match ts with
    | none    => pure ()
    | some ts => evalTactic $ ← `(tactic| have $hi:ident := @$hi:ident $ts*)
    evalTactic $ ← `(tactic| cases $hi:ident with | intro n $hi:ident => ?_)
    match h with
    | none   => evalTactic $
      ← `(tactic| exact ⟨n + 1, by simp only [stepN, step]; exact $hi:ident⟩)
    | some h => evalTactic $
      ← `(tactic| exact ⟨n + 1, by simp only [stepN, step, $h];exact $hi:ident⟩)

theorem State.retProgression :
    ∃ n, (ret c k v^[n]).isEnd ∨ (ret c k v^[n]).isProg := by
  induction k generalizing c v with
  | exit => exact ⟨1, by simp [stepN, step, isEnd]⟩
  | seq  => exact ⟨1, by simp [stepN, step, isProg]⟩
  | decl nm _ hi => step_induction hi using (c.insert nm v), .nil
  | fork =>
    cases v with
    | lit l =>
      cases l with
      | bool b => cases b <;> exact ⟨1, by simp [stepN, step, isProg]⟩
      | _ => exact ⟨1, by simp [stepN, step, isEnd]⟩
    | _ => exact ⟨1, by simp [stepN, step, isEnd]⟩
  | loop _ _ _ hi =>
    cases v with
    | lit l =>
      cases l with
      | bool b =>
        cases b with
        | true  => exact ⟨1, by simp [stepN, step, isProg]⟩
        | false => step_induction hi using c, .nil
      | _ => exact ⟨1, by simp [stepN, step, isEnd]⟩
    | _ => exact ⟨1, by simp [stepN, step, isEnd]⟩
  | unOp o _ hi =>
    cases h : v.unOp o with
    | error => exact ⟨1, by simp [stepN, step, h, isEnd]⟩
    | ok v' => step_induction hi using c, v' with h
  | block c' _ hi => step_induction hi using c', v
  | print _ hi => step_induction hi using c, .nil with dbgTrace
  | binOp₂ o v₂ _ hi =>
    cases h : v₂.binOp v o with
    | error => exact ⟨1, by simp [stepN, step, h, isEnd]⟩
    | ok v' => step_induction hi using c, v' with h
  | binOp₁ o e k hi =>
    sorry
    -- cases @exprProgression e c (Continuation.binOp₂ o v k) with | intro n h =>
    -- exact ⟨n + 1, by simp only [stepN, step]; exact h⟩
  | app e es k hi =>
    cases v with
    | lam lm =>
      cases lm with
      | mk ns h p =>
        cases h' : consume p ns es with
        | none =>
          exists 1
          simp only [stepN, step]
          split
          next h'' => simp only [h'] at h''
          next h'' => simp only [h'] at h''
          simp [isEnd]
        | some x =>
          match x with
          | (some l, p') =>
            cases @hi c (.lam $ .mk l (noDupOfConsumeNoDup h h') p') with
            | intro n hi =>
              exists n + 1
              simp [stepN, step]
              split
              next h'' =>
                simp [h'] at h''
                simp [← h'', hi]
              all_goals { next h'' => simp [h''] at h' }
          | (none, _) =>
            exists 1
            simp only [stepN, step]
            split
            next h'' => simp [h'] at h''
            simp [isProg]
            simp [isEnd]
    | _ => exact ⟨1, by simp [stepN, step, isEnd]⟩

open Lean.Parser.Tactic in
syntax "step_ret " num " using " term ", " term ", " term
  (" with " simpLemma)? : tactic

open Lean.Elab.Tactic in
set_option hygiene false in
elab_rules : tactic
  | `(tactic| step_ret $n using $v, $c, $k $[with $h]?) => do
    evalTactic $
      ← `(tactic| cases @retProgression $v $c $k with | intro n_ h_ => ?_)
    match h with
    | none => evalTactic $
      ← `(tactic| exact ⟨n_ + $n, by simp only [stepN, step]; exact h_⟩)
    | some h => evalTactic $
      ← `(tactic| exact ⟨n_ + $n, by simp only [stepN, step, $h]; exact h_⟩)

theorem State.exprProgression :
    ∃ n, (expr c k e^[n]).isEnd ∨ (expr c k e^[n]).isProg := by
  cases e with
  | lit l =>
    cases k with
    | exit => exact ⟨2, by simp [stepN, step, isEnd]⟩
    | seq  => exact ⟨2, by simp [stepN, step, isProg]⟩
    | decl nm k => step_ret 2 using c.insert nm (.lit l), k, .nil
    | print k => step_ret 2 using c, k, .nil
    | fork e pT pF k => step_ret 1 using c, .fork e pT pF k, .lit l
    | loop e p k => step_ret 1 using c, .loop e p k, .lit l
    | unOp o k => step_ret 1 using c, .unOp o k, .lit l
    | binOp₁ o e₂ k => step_ret 1 using c, .binOp₁ o e₂ k, .lit l
    | binOp₂ o v₁ k => step_ret 1 using c, .binOp₂ o v₁ k, .lit l
    | app e es k => step_ret 1 using c, .app e es k, .lit l
    | block c' k => step_ret 1 using c, .block c' k, .lit l
  | list l =>
    cases k with
    | exit => exact ⟨2, by simp [stepN, step, isEnd]⟩
    | seq  => exact ⟨2, by simp [stepN, step, isProg]⟩
    | decl nm k => step_ret 2 using c.insert nm (.list l), k, .nil
    | print k => step_ret 2 using c, k, .nil
    | fork e pT pF k => step_ret 1 using c, .fork e pT pF k, .list l
    | loop e p k => step_ret 1 using c, .loop e p k, .list l
    | unOp o k => step_ret 1 using c, .unOp o k, .list l
    | binOp₁ o e₂ k => step_ret 1 using c, .binOp₁ o e₂ k, .list l
    | binOp₂ o v₁ k => step_ret 1 using c, .binOp₂ o v₁ k, .list l
    | app e es k => step_ret 1 using c, .app e es k, .list l
    | block c' k => step_ret 1 using c, .block c' k, .list l
  | var nm =>
    cases h' : c[nm] with
    | none => exact ⟨1, by simp [stepN, step, h', isEnd]⟩
    | some v =>
      cases k with
      | exit => exact ⟨2, by simp [stepN, step, h', isEnd]⟩
      | seq  => exact ⟨2, by simp [stepN, step, h', isProg]⟩
      | decl nm k => step_ret 2 using c.insert nm v, k, .nil with h'
      | print k => step_ret 2 using c, k, .nil with h'
      | fork e pT pF k => step_ret 1 using c, .fork e pT pF k, v with h'
      | loop e p k => step_ret 1 using c, .loop e p k, v with h'
      | unOp o k => step_ret 1 using c, .unOp o k, v with h'
      | binOp₁ o e₂ k => step_ret 1 using c, .binOp₁ o e₂ k, v with h'
      | binOp₂ o v₁ k => step_ret 1 using c, .binOp₂ o v₁ k, v with h'
      | app e es k => step_ret 1 using c, .app e es k, v with h'
      | block c' k => step_ret 1 using c, .block c' k, v with h'
  | lam l =>
    cases k with
    | exit => exact ⟨2, by simp [stepN, step, isEnd]⟩
    | seq  => exact ⟨2, by simp [stepN, step, isProg]⟩
    | decl nm k => step_ret 2 using c.insert nm (.lam l), k, .nil
    | print k => step_ret 2 using c, k, .nil
    | fork e pT pF k => step_ret 1 using c, .fork e pT pF k, .lam l
    | loop e p k => step_ret 1 using c, .loop e p k, .lam l
    | unOp o k => step_ret 1 using c, .unOp o k, .lam l
    | binOp₁ o e₂ k => step_ret 1 using c, .binOp₁ o e₂ k, .lam l
    | binOp₂ o v₁ k => step_ret 1 using c, .binOp₂ o v₁ k, .lam l
    | app e es k => step_ret 1 using c, .app e es k, .lam l
    | block c' k => step_ret 1 using c, .block c' k, .lam l
  | app e es =>
    sorry
    -- cases @exprProgression e c (.app e es k) with | intro n h =>
    -- exact ⟨n + 1, by rw [stepN, step]; exact h⟩
  | unOp o e =>
    sorry
    -- cases @exprProgression e c (.unOp o e k) with | intro n h =>
    -- exact ⟨n + 1, by rw [stepN, step]; exact h⟩
  | binOp o e₁ e₂ =>
    sorry
    -- cases @exprProgression e₁ c (.binOp₁ o e₂ k) with | intro n h =>
    -- exact ⟨n + 1, by rw [stepN, step]; exact h⟩

theorem State.Progression : ∃ n, (s^[n]).isEnd ∨ (s^[n]).isProg := by
  cases s with
  | prog  => exact ⟨0, by simp [stepN, isProg]⟩
  | done  => exact ⟨0, by simp [stepN,  isEnd]⟩
  | error => exact ⟨0, by simp [stepN,  isEnd]⟩
  | ret  v c k => exact retProgression
  | expr e c k => exact exprProgression


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (h1 : ¬ (α ∈ ℚ)) :
let subset_of_unit : set ℝ := {a | ∃ a', (a : ℝ) = a' % 1 ∧  a' ∈ ℤ} in
let dense_subset : set ℝ → Prop := λ (S : set ℝ), ∀ x, x ∈ S → ∃ y, y ∈ S ∧ |y - x| < (1 : ℝ) in
subset_of_unit ⊆ (Icc 0 1) ∧ dense_subset subset_of_unit :=
begin
  have h2 : ∀ (i j : ℤ), i ≠ j → {i * α % 1} ≠ {j * α % 1},
  from sorry,

  have h3 : ∀ (i j : ℤ), i ≠ j → {i * α % 1} ≠ {j * α % 1},
  from sorry,

  have h4 : ∀ (i j : ℤ), i ≠ j → {i * α % 1} ≠ {j * α % 1},
  from sorry,
  have h5 : {a | ∃ a', (a : ℝ) = a' % 1 ∧ a' ∈ ℤ} ⊆ (Icc 0 1),
  from sorry,
  have h6 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h7 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h8 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h9 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h10 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h11 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h12 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h13 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h14 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h15 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h16 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h17 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h18 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h19 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h20 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h21 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h22 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h23 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h24 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h25 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h26 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h27 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h28 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h29 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h30 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h31 : ∀ (S : set ℝ), dense_subset S → ∀ x, x ∈ S → ∃ y : ℝ, y ∈ S ∧ |y - x| < (1 : ℝ),
  from sorry,
  have h32 : ∀ (S : set ℝ), dense_subset S → ∀ x
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit : ∀ (α : ℝ) (α_irrational : ¬ ∃ (i j : ℤ), α = i / j), ∃ (S : set ℝ) (S_infinite : infinite S) (S_dense : is_dense S),
(∀ (n : ℤ), ∃ (a : ℝ), a ∈ S ∧ a = n / α) ∧
(∀ (a : ℝ), a ∈ S → ∀ (b : ℝ), b ∈ S → ∀ (n : ℤ), ∃ (a_b : ℝ), a_b ∈ S ∧ a_b = |a - b| ∧ a_b = n / α) :=
begin
  assume (α : ℝ) (α_irrational : ¬ ∃ (i j : ℤ), α = i / j),
  let S := {x : ℝ | ∃ (i : ℤ), x = i / α},
  have S_infinite : infinite S, from sorry,
  have S_dense : is_dense S, from sorry,
  have S_nonempty : nonempty S, from sorry,
  have S_in_unit_interval : ∀ (a : ℝ), a ∈ S → ∃ (i : ℤ), a = i / α ∧ a ∈ (Icc (0 : ℝ) 1), from sorry,
  have S_bounded : bounded S, from sorry,

  have h1 : ∀ (a b : ℝ), a ∈ S ∧ b ∈ S → (∃ (i j : ℤ), a = i / α ∧ b = j / α) ∧ ¬ (a = b), from sorry,
  have h2 : ∀ (a : ℝ), a ∈ S → (∃ (i : ℤ), a = i / α) ∧ ∀ (b : ℝ), b ∈ S → ¬ (a = b), from sorry,
  have h3 : ∀ (a : ℝ), a ∈ S → (∃ (i : ℤ), a = i / α) ∧ ∀ (b : ℝ), b ∈ S → |a - b| ∈ S, from sorry,

  use S,
  have h4 : (∀ (n : ℤ), ∃ (a : ℝ), a ∈ S ∧ a = n / α) ∧
    (∀ (a : ℝ), a ∈ S → ∀ (b : ℝ), b ∈ S → ∀ (n : ℤ), ∃ (a_b : ℝ), a_b ∈ S ∧ a_b = |a - b| ∧ a_b = n / α), from sorry,

  show (∀ (n : ℤ), ∃ (a : ℝ), a ∈ S ∧ a = n / α) ∧
    (∀ (a : ℝ), a ∈ S → ∀ (b : ℝ), b ∈ S → ∀ (n : ℤ), ∃ (a_b : ℝ), a_b ∈ S ∧ a_b = |a - b| ∧ a_b = n / α), from sorry,
end

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit_dense (α : ℝ) (h1 : irrational α) : ∃ S, dense S ∧ S ⊆ {x : ℝ | 0 ≤ x ∧ x ≤ 1} :=
begin
  have h2 : ∀ (i : ℤ) (j : ℤ), i ≠ j → ¬(i * α) = (j * α),
  from sorry,
  have h3 : ∃ S, infinite S ∧ S ⊆ {x : ℝ | 0 ≤ x ∧ x ≤ 1},
  from sorry,
  have h4 : ∃ S, dense S ∧ S ⊆ {x : ℝ | 0 ≤ x ∧ x ≤ 1},
  from sorry,

  show ∃ S, dense S ∧ S ⊆ {x : ℝ | 0 ≤ x ∧ x ≤ 1}, from sorry,
end

--OUTPUT 4
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_irrational_orbit (α : ℝ) (hα : α ∉ ℚ) :
∀ ε > 0, ∃ N ∈ ℤ, ∀ i > N, ∃ j ∈ ℤ, |(i*α) - j| < ε :=
begin
  assume (ε : ℝ) (hε : ε > 0),
  have h1 : ∃ N ∈ ℤ, ∀ i > N, ∃ j ∈ ℤ, |i*α - j| < ε, from sorry,
  show ∃ N ∈ ℤ, ∀ i > N, ∃ j ∈ ℤ, |(i*α) - j| < ε, from sorry,
end

--OUTPUT 5
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit {α : Type*} [linear_ordered_field α] (α_irr : ¬ is_rat α) :
  ∀ (a : α),
  let
    S : set α := {(n : ℤ) ↦ n * a | n : ℤ}
  in
  ∀ (y : α), ∀ (ε : α), ε > 0 → ∃ (x : α), x ∈ S ∧ abs(y - x) < ε :=
begin
  assume (a : α) (y : α) (ε : α),
  assume (h1 : ε > 0),
  have h2 : ∀ (a b : ℤ), a ≠ b → ∃ (n : ℤ), (n : α) * a ≠ (n : α) * b, from by {
    assume (a b : ℤ) (h2 : a ≠ b),
    have h3 : (a - b) ≠ 0, from sorry,
    have h4 : ∃ (n : ℤ), (n : α) * (a - b) ≠ 0, from by {
      have h5 : ∃ (n : ℤ), (n : α) * (a - b) = 1, from sorry,
      have h6 : ∃ (n : ℤ), (n : α) * (a - b) ≠ 0, from sorry,
      show ∃ (n : ℤ), (n : α) * (a - b) ≠ 0, from sorry,
    },
    cases h4 with (n : ℤ) (h4 : (n : α) * (a - b) ≠ 0),
    use n,
    show (n : α) * a ≠ (n : α) * b, from sorry,
  },
  have h3 : ∀ (a b : ℤ), a ≠ b → ∃ (n : ℤ), (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S, from by {
    assume (a b : ℤ) (h3 : a ≠ b),
    have h4 : ∃ (n : ℤ), (n : α) * a ≠ (n : α) * b, from sorry,
    cases h4 with (n : ℤ) (h4 : (n : α) * a ≠ (n : α) * b),
    use n,
    show (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S, from sorry,
  },
  have h4 : ∀ (a b : ℤ), a ≠ b → ∃ (n : ℤ), (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S ∧ abs((n : α) * a - (n : α) * b) < ε, from by {
    assume (a b : ℤ) (h4 : a ≠ b),
    have h5 : ∃ (n : ℤ), (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S, from sorry,
    cases h5 with (n : ℤ) (h5 : (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S),
    have h6 : ∃ (n : ℤ), abs((n : α) * a - (n : α) * b) < ε, from sorry,
    cases h6 with (n : ℤ) (h6 : abs((n : α) * a - (n : α) * b) < ε),
    use n,
    show (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S ∧ abs((n : α) * a - (n : α) * b) < ε, from sorry,
  },
  have h5 : ∀ (a b : ℤ), a ≠ b → ∃ (n : ℤ), (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S ∧ abs((n : α) * a - (n : α) * b) < ε ∧ abs((n : α) * a - y) < ε, from by {
    assume (a b : ℤ) (h5 : a ≠ b),
    have h6 : ∃ (n : ℤ), (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S ∧ abs((n : α) * a - (n : α) * b) < ε, from sorry,
    cases h6 with (n : ℤ) (h6 : (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S ∧ abs((n : α) * a - (n : α) * b) < ε),
    have h7 : ∃ (n : ℤ), abs((n : α) * a - y) < ε, from sorry,
    cases h7 with (n : ℤ) (h7 : abs((n : α) * a - y) < ε),
    use n,
    show (n : α) * a ≠ (n : α) * b ∧ (n : α) * a ∈ S ∧ (n : α) * b ∈ S ∧ abs((n : α) * a - (n : α) * b) < ε ∧ abs((n : α) * a - y) < ε, from sorry,
  },
  show ∃ (x : α), x ∈ S ∧ abs(y - x) < ε, from sorry,
end

--OUTPUT 6
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (h : α ∉ ℚ) : ∃ S : set ℝ,
  (∀ (i j : ℤ), i ≠ j → {i • α} ≠ {j • α}) ∧
  ∀ (y : ℝ), y ∈ [0,1] → ∃ (x : ℝ), x ∈ S ∧ |y - x| < 1 :=
sorry

/--`theorem`
Product of two irrational numbers is irrational
`proof`
Let $\alpha$ and $\beta$ be irrational numbers. We will show that $\alpha \beta$ is irrational.

Suppose $\alpha \beta \in \mathbb{Q}$. Then there exist $m, n \in \mathbb{Z}$, $m>0$, $n>0$ such that
$$
\alpha \beta=\frac{m}{n}.
$$

We know that $\alpha \notin \mathbb{Q}$, so $\frac{m}{n} \neq \alpha$. But, since $\alpha$ is irrational, we must have $\frac{m}{n}>\alpha$.

Since $\frac{m}{n}>\alpha$ and $\alpha \beta=\frac{m}{n}$, we have $\alpha \beta>\alpha^2$.

Multiplying by $\alpha$, we get $\alpha^2 \beta>\alpha^3$.

Since $\alpha \beta$ is irrational, we have $\alpha^2 \beta \neq \alpha^3$. But, since $\alpha^2 \beta>\alpha^3$, we must have $\alpha^2 \beta>\alpha^3$.

Thus, we have $\alpha^2 \beta>\alpha^3$ and $\alpha^2 \beta \neq \alpha^3$.

This is a contradiction, since if $a>b$ and $a \neq b$, then $a$ is not less than $b$.

Hence, $\alpha \beta$ must be irrational.

QED
-/
theorem product_of_two_irrationals (α β : ℝ) (h1 : α ∉ ℚ) (h2 : β ∉ ℚ) : α * β ∉ ℚ :=
sorry

end

--OUTPUT 7
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit_dense (α : ℝ) (h : irrational α) : ∀ x ∈ set.Icc 0 1, ∃ y ∈ set.Icc 0 1, y ≠ x ∧ y ∈ {n : ℤ | n * α} :=
begin
  assume (x : ℝ) (hx : x ∈ set.Icc 0 1),
  let S := {n : ℤ | n * α},
  have h1 : ∀ i j : ℤ, (i : ℝ) * α ≠ (j : ℝ) * α,
  from begin
    assume (i j : ℤ) (h1 : (i : ℝ) * α = (j : ℝ) * α),
    have h2 : (i : ℝ) * α - ⌊(i : ℝ) * α⌋ = (j : ℝ) * α - ⌊(j : ℝ) * α⌋, from sorry,
    have h3 : (i : ℝ) * α - ⌊(i : ℝ) * α⌋ = (j : ℝ) * α - ⌊(j : ℝ) * α⌋, from sorry,
    have h4 : α = (⌊(i : ℝ) * α⌋ - ⌊(j : ℝ) * α⌋)/(i - j), from sorry,
    have h5 : α ∈ ℚ, from sorry,
    have h6 : irrational α, from sorry,
    have h7 : ¬ (α ∈ ℚ), from sorry,
    show false, from sorry,
  end,
  have h2 : infinite (S : set ℝ), from sorry,
  have h3 : ∃ x ∈ S, ∀ ε > 0, ∃ y ∈ S, y ≠ x ∧ |y - x| < ε, from sorry,
  obtain x0 hx0, from h3,
  have h4 : ∀ ε > 0, ∃ y ∈ S, y ≠ x0 ∧ |y - x0| < ε, from sorry,
  have h5 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ y ∈ S, y ≠ x0 ∧ ε' < ε, from sorry,
  have h6 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ y ∈ S, y ≠ x0 ∧ ε' < ε ∧ ε'' < ε, from sorry,
  have h7 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0, from sorry,
  have h8 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0 ∧ (n : ℝ) * α ∈ S, from sorry,
  have h9 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0 ∧ (n : ℝ) * α ∈ S ∧ (n : ℝ) * α ∈ set.Icc 0 1, from sorry,
  have h10 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0 ∧ (n : ℝ) * α ∈ S ∧ (n : ℝ) * α ∈ set.Icc 0 1 ∧ (n : ℝ) * α ≠ x, from sorry,
  have h11 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0 ∧ (n : ℝ) * α ∈ S ∧ (n : ℝ) * α ∈ set.Icc 0 1 ∧ (n : ℝ) * α ≠ x ∧ (n : ℝ) * α ∈ {n : ℤ | n * α}, from sorry,
  have h12 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0 ∧ (n : ℝ) * α ∈ S ∧ (n : ℝ) * α ∈ set.Icc 0 1 ∧ (n : ℝ) * α ≠ x ∧ (n : ℝ) * α ∈ {n : ℤ | n * α} ∧ (n : ℝ) * α ∈ set.Icc 0 1, from sorry,
  have h13 : ∀ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0 ∧ (n : ℝ) * α ∈ S ∧ (n : ℝ) * α ∈ set.Icc 0 1 ∧ (n : ℝ) * α ≠ x ∧ (n : ℝ) * α ∈ {n : ℤ | n * α} ∧ (n : ℝ) * α ∈ set.Icc 0 1 ∧ (n : ℝ) * α ∈ S, from sorry,
  have h14 : ∃ ε > 0, ∃ (ε' : ℝ) > 0, ∃ (ε'' : ℝ) > 0, ∃ n : ℤ, n ≠ 0 ∧ ε' < ε ∧ ε'' < ε ∧ (n : ℝ) * α ≠ x0 ∧ (n : ℝ) * α ∈ S ∧ (n : ℝ) * α ∈ set.Icc 0 1 ∧ (n : ℝ) * α ≠ x ∧ (n : ℝ) * α ∈ {n : ℤ | n * α} ∧ (n : ℝ) * α ∈ set.Icc 0 1 ∧ (n : ℝ) * α ∈ S, from sorry,
  obtain (ε : ℝ) (h15 : ε > 0) (ε' : ℝ) (h16 : ε' > 0) (ε'' : ℝ) (h17 : ε'' > 0) (n : ℤ) (hn : n ≠ 0) (hn0 : (n : ℝ) * α ≠ x0) (hn1 : (n : ℝ) * α ∈ S) (hn2 : (n : ℝ) * α ∈ set.Icc 0 1) (hn3 : (n : ℝ) * α ≠ x) (hn4 : (n : ℝ) * α ∈ {n : ℤ | n * α}) (hn5 : (n : ℝ) * α ∈ set.Icc 0 1) (hn6 : (n :
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=dense_irrational_orbit (α : ℝ) [irrational α] : ∃ S : set ℝ, ∀ x ∈ S, x ∈ Icc 0 1 ∧ ∀ y ∈ S, x ≠ y → x ≠ y ∧ dense S :=
begin
  have h1 : ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h2 : ∀ i : ℤ, {i * α} ∈ Icc 0 1, from sorry,
  have h3 : ∀ i : ℤ, {i * α} ∈ set.range (λ (i : ℤ), {i * α}), from sorry,
  have h4 : set.range (λ (i : ℤ), {i * α}) ⊆ Icc 0 1, from sorry,
  have h5 : dense (set.range (λ (i : ℤ), {i * α})), from sorry,
  have h6 : set.range (λ (i : ℤ), {i * α}) ≠ ∅, from sorry,

  show ∃ S : set ℝ, ∀ x ∈ S, x ∈ Icc 0 1 ∧ ∀ y ∈ S, x ≠ y → x ≠ y ∧ dense S,
  from ⟨set.range (λ (i : ℤ), {i * α}),
       sorry,
       sorry,
       sorry,
       sorry,
       sorry⟩,
end

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

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

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

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

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

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

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

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

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

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

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

Setting $b = a$, this becomes:

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

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

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

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from sorry,

  assume (h7 : ε > 0),
  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,
  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := sorry,
  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from sorry,

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from sorry,

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from sorry,
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

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


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Sean Leather
-/
import algebra.free_monoid
import algebra.opposites
import control.traversable.instances
import control.traversable.lemmas
import category_theory.category
import category_theory.endomorphism
import category_theory.types
import category_theory.category.Kleisli

/-!

# List folds generalized to `traversable`

Informally, we can think of `foldl` as a special case of `traverse` where we do not care about the
reconstructed data structure and, in a state monad, we care about the final state.

The obvious way to define `foldl` would be to use the state monad but it
is nicer to reason about a more abstract interface with `fold_map` as a
primitive and `fold_map_hom` as a defining property.

```
def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω := ...

lemma fold_map_hom (α β)
  [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
...
```

`fold_map` uses a monoid ω to accumulate a value for every element of
a data structure and `fold_map_hom` uses a monoid homomorphism to
substitute the monoid used by `fold_map`. The two are sufficient to
define `foldl`, `foldr` and `to_list`. `to_list` permits the
formulation of specifications in terms of operations on lists.

Each fold function can be defined using a specialized
monoid. `to_list` uses a free monoid represented as a list with
concatenation while `foldl` uses endofunctions together with function
composition.

The definition through monoids uses `traverse` together with the
applicative functor `const m` (where `m` is the monoid). As an
implementation, `const` guarantees that no resource is spent on
reconstructing the structure during traversal.

A special class could be defined for `foldable`, similarly to Haskell,
but the author cannot think of instances of `foldable` that are not also
`traversable`.
-/

universes u v

open ulift category_theory opposite

namespace monoid
variables {m : Type u → Type u} [monad m]
variables {α β : Type u}
/--
For a list, foldl f x [y₀,y₁] reduces as follows:

```
calc  foldl f x [y₀,y₁]
    = foldl f (f x y₀) [y₁]      : rfl
... = foldl f (f (f x y₀) y₁) [] : rfl
... = f (f x y₀) y₁              : rfl
```
with
```
f : α → β → α
x : α
[y₀,y₁] : list β
```

We can view the above as a composition of functions:
```
... = f (f x y₀) y₁              : rfl
... = flip f y₁ (flip f y₀ x)    : rfl
... = (flip f y₁ ∘ flip f y₀) x  : rfl
```

We can use traverse and const to construct this composition:
```
calc   const.run (traverse (λ y, const.mk' (flip f y)) [y₀,y₁]) x
     = const.run ((::) <$> const.mk' (flip f y₀) <*> traverse (λ y, const.mk' (flip f y)) [y₁]) x
...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
         ( (::) <$> const.mk' (flip f y₁) <*> traverse (λ y, const.mk' (flip f y)) [] )) x
...  = const.run ((::) <$> const.mk' (flip f y₀) <*>
         ( (::) <$> const.mk' (flip f y₁) <*> pure [] )) x
...  = const.run ( ((::) <$> const.mk' (flip f y₁) <*> pure []) ∘
         ((::) <$> const.mk' (flip f y₀)) ) x
...  = const.run ( const.mk' (flip f y₁) ∘ const.mk' (flip f y₀) ) x
...  = const.run ( flip f y₁ ∘ flip f y₀ ) x
...  = f (f x y₀) y₁
```

And this is how `const` turns a monoid into an applicative functor and
how the monoid of endofunctions define `foldl`.
-/
@[reducible] def foldl (α : Type u) : Type u := (End α)ᵒᵖ
def foldl.mk (f : α → α) : foldl α := op f
def foldl.get (x : foldl α) : α → α := unop x
def foldl.of_free_monoid (f : β → α → β) (xs : free_monoid α) : monoid.foldl β :=
op $ flip (list.foldl f) xs

@[reducible] def foldr (α : Type u) : Type u := End α
def foldr.mk (f : α → α) : foldr α := f
def foldr.get (x : foldr α) : α → α := x
def foldr.of_free_monoid (f : α → β → β) (xs : free_monoid α) : monoid.foldr β :=
flip (list.foldr f) xs

@[reducible] def mfoldl (m : Type u → Type u) [monad m] (α : Type u) : Type u :=
opposite $ End $ Kleisli.mk m α
def mfoldl.mk (f : α → m α) : mfoldl m α := op f
def mfoldl.get (x : mfoldl m α) : α → m α := unop x
def mfoldl.of_free_monoid (f : β → α → m β) (xs : free_monoid α) : monoid.mfoldl m β :=
op $ flip (list.mfoldl f) xs

@[reducible] def mfoldr (m : Type u → Type u) [monad m] (α : Type u) : Type u :=
End $ Kleisli.mk m α
def mfoldr.mk (f : α → m α) : mfoldr m α := f
def mfoldr.get (x : mfoldr m α) : α → m α := x
def mfoldr.of_free_monoid (f : α → β → m β) (xs : free_monoid α) : monoid.mfoldr m β :=
flip (list.mfoldr f) xs

end monoid

namespace traversable
open monoid functor

section defs
variables {α β : Type u} {t : Type u → Type u} [traversable t]

def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω :=
traverse (const.mk' ∘ f)

def foldl (f : α → β → α) (x : α) (xs : t β) : α :=
(fold_map (foldl.mk ∘ flip f) xs).get x

def foldr (f : α → β → β) (x : β) (xs : t α) : β :=
(fold_map (foldr.mk ∘ f) xs).get x

/--
Conceptually, `to_list` collects all the elements of a collection
in a list. This idea is formalized by

  `lemma to_list_spec (x : t α) : to_list x = fold_map free_monoid.mk x`.

The definition of `to_list` is based on `foldl` and `list.cons` for
speed. It is faster than using `fold_map free_monoid.mk` because, by
using `foldl` and `list.cons`, each insertion is done in constant
time. As a consequence, `to_list` performs in linear.

On the other hand, `fold_map free_monoid.mk` creates a singleton list
around each element and concatenates all the resulting lists. In
`xs ++ ys`, concatenation takes a time proportional to `length xs`. Since
the order in which concatenation is evaluated is unspecified, nothing
prevents each element of the traversable to be appended at the end
`xs ++ [x]` which would yield a `O(n²)` run time. -/
def to_list : t α → list α :=
list.reverse ∘ foldl (flip list.cons) []

def length (xs : t α) : ℕ :=
down $ foldl (λ l _, up $ l.down + 1) (up 0) xs

variables {m : Type u → Type u} [monad m]

def mfoldl (f : α → β → m α) (x : α) (xs : t β) : m α :=
(fold_map (mfoldl.mk ∘ flip f) xs).get x

def mfoldr (f : α → β → m β) (x : β) (xs : t α) : m β :=
(fold_map (mfoldr.mk ∘ f) xs).get x

end defs

section applicative_transformation
variables {α β γ : Type u}

open function (hiding const) is_monoid_hom

def map_fold [monoid α] [monoid β] (f : α → β) [is_monoid_hom f] :
  applicative_transformation (const α) (const β) :=
{ app := λ x, f,
  preserves_seq'  := by { intros, simp only [map_mul f, (<*>)], },
  preserves_pure' := by { intros, simp only [map_one f, pure] } }

def free.mk : α → free_monoid α := list.ret

def free.map (f : α → β) : free_monoid α → free_monoid β := list.map f

lemma free.map_eq_map (f : α → β) (xs : list α) :
  f <$> xs = free.map f xs := rfl

instance (f : α → β) : is_monoid_hom (free.map f) :=
{ map_mul := λ x y,
    by simp only [free.map, free_monoid.mul_def, list.map_append, free_add_monoid.add_def],
  map_one := by simp only [free.map, free_monoid.one_def, list.map, free_add_monoid.zero_def] }

instance fold_foldl (f : β → α → β) :
  is_monoid_hom (foldl.of_free_monoid f) :=
{ map_one := rfl,
  map_mul := by intros; simp only [free_monoid.mul_def, foldl.of_free_monoid, flip, unop_op,
    list.foldl_append, op_inj_iff]; refl }

lemma foldl.unop_of_free_monoid  (f : β → α → β) (xs : free_monoid α) (a : β) :
  unop (foldl.of_free_monoid f xs) a = list.foldl f a xs := rfl

instance fold_foldr (f : α → β → β) :
  is_monoid_hom (foldr.of_free_monoid f) :=
{ map_one := rfl,
  map_mul :=
    begin
      intros,
      simp only [free_monoid.mul_def, foldr.of_free_monoid, list.foldr_append, flip],
      refl
    end }

variables (m : Type u → Type u) [monad m] [is_lawful_monad m]

@[simp]
lemma mfoldl.unop_of_free_monoid  (f : β → α → m β) (xs : free_monoid α) (a : β) :
  unop (mfoldl.of_free_monoid f xs) a = list.mfoldl f a xs := rfl

instance fold_mfoldl (f : β → α → m β) :
  is_monoid_hom (mfoldl.of_free_monoid f) :=
{ map_one := rfl,
  map_mul := by intros; apply unop_injective; ext; apply list.mfoldl_append }

instance fold_mfoldr (f : α → β → m β) :
  is_monoid_hom (mfoldr.of_free_monoid f) :=
{ map_one := rfl,
  map_mul := by intros; ext; apply list.mfoldr_append }

variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
open is_lawful_traversable

lemma fold_map_hom
  [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
calc  f (fold_map g x)
    = f (traverse (const.mk' ∘ g) x)  : rfl
... = (map_fold f).app _ (traverse (const.mk' ∘ g) x) : rfl
... = traverse ((map_fold f).app _ ∘ (const.mk' ∘ g)) x : naturality (map_fold f) _ _
... = fold_map (f ∘ g) x : rfl

lemma fold_map_hom_free
  [monoid β] (f : free_monoid α → β) [is_monoid_hom f] (x : t α) :
  f (fold_map free.mk x) = fold_map (f ∘ free.mk) x :=
fold_map_hom _ _ x

variable {m}

lemma fold_mfoldl_cons (f : α → β → m α) (x : β) (y : α) :
  list.mfoldl f y (free.mk x) = f y x :=
by simp only [free.mk, list.ret, list.mfoldl, bind_pure]

lemma fold_mfoldr_cons (f : β → α → m α) (x : β) (y : α) :
  list.mfoldr f y (free.mk x) = f x y :=
by simp only [free.mk, list.ret, list.mfoldr, pure_bind]

end applicative_transformation

section equalities
open is_lawful_traversable list (cons)
variables {α β γ : Type u}
variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]

@[simp]
lemma foldl.of_free_monoid_comp_free_mk (f : α → β → α) :
  foldl.of_free_monoid f ∘ free.mk = foldl.mk ∘ flip f := rfl

@[simp]
lemma foldr.of_free_monoid_comp_free_mk (f : β → α → α) :
  foldr.of_free_monoid f ∘ free.mk = foldr.mk ∘ f := rfl

@[simp]
lemma mfoldl.of_free_monoid_comp_free_mk {m} [monad m] [is_lawful_monad m] (f : α → β → m α) :
  mfoldl.of_free_monoid f ∘ free.mk = mfoldl.mk ∘ flip f :=
by ext; simp only [(∘), mfoldl.of_free_monoid, mfoldl.mk, flip, fold_mfoldl_cons]; refl

@[simp]
lemma mfoldr.of_free_monoid_comp_free_mk {m} [monad m] [is_lawful_monad m] (f : β → α → m α) :
  mfoldr.of_free_monoid f ∘ free.mk = mfoldr.mk ∘ f :=
by { ext, simp only [(∘), mfoldr.of_free_monoid, mfoldr.mk, flip, fold_mfoldr_cons] }

lemma to_list_spec (xs : t α) :
  to_list xs = (fold_map free.mk xs : free_monoid _) :=
eq.symm $
calc  fold_map free.mk xs
    = (fold_map free.mk xs).reverse.reverse : by simp only [list.reverse_reverse]
... = (list.foldr cons [] (fold_map free.mk xs).reverse).reverse
                 : by simp only [list.foldr_eta]
... = (unop (foldl.of_free_monoid (flip cons) (fold_map free.mk xs)) []).reverse
                 : by simp only [flip,list.foldr_reverse,foldl.of_free_monoid, unop_op]
... = to_list xs : begin
                     rw fold_map_hom_free (foldl.of_free_monoid (flip cons)),
                     simp only [to_list, foldl, list.reverse_inj, foldl.get,
                       foldl.of_free_monoid_comp_free_mk],
                     all_goals { apply_instance }
                   end

lemma fold_map_map [monoid γ]  (f : α → β) (g : β → γ) (xs : t α) :
  fold_map g (f <$> xs) = fold_map (g ∘ f) xs :=
by simp only [fold_map,traverse_map]

lemma foldl_to_list (f : α → β → α) (xs : t β) (x : α) :
  foldl f x xs = list.foldl f x (to_list xs) :=
begin
  rw ← foldl.unop_of_free_monoid,
  simp only [foldl, to_list_spec, fold_map_hom_free (foldl.of_free_monoid f),
    foldl.of_free_monoid_comp_free_mk, foldl.get]
end

lemma foldr_to_list (f : α → β → β) (xs : t α) (x : β) :
  foldr f x xs = list.foldr f x (to_list xs) :=
begin
  change _ = foldr.of_free_monoid _ _ _,
  simp only [foldr, to_list_spec, fold_map_hom_free (foldr.of_free_monoid f),
    foldr.of_free_monoid_comp_free_mk, foldr.get]
end

lemma to_list_map (f : α → β) (xs : t α) :
  to_list (f <$> xs) = f <$> to_list xs :=
by simp only [to_list_spec,free.map_eq_map,fold_map_hom (free.map f), fold_map_map]; refl

@[simp] theorem foldl_map (g : β → γ) (f : α → γ → α) (a : α) (l : t β) :
  foldl f a (g <$> l) = foldl (λ x y, f x (g y)) a l :=
by simp only [foldl, fold_map_map, (∘), flip]

@[simp] theorem foldr_map (g : β → γ) (f : γ → α → α) (a : α) (l : t β) :
  foldr f a (g <$> l) = foldr (f ∘ g) a l :=
by simp only [foldr, fold_map_map, (∘), flip]

@[simp] theorem to_list_eq_self {xs : list α} : to_list xs = xs :=
begin
  simp only [to_list_spec, fold_map, traverse],
  induction xs,
  case list.nil { refl },
  case list.cons : _ _ ih { unfold list.traverse list.ret, rw ih, refl }
end

theorem length_to_list {xs : t α} : length xs = list.length (to_list xs) :=
begin
  unfold length,
  rw foldl_to_list,
  generalize : to_list xs = ys,
  let f := λ (n : ℕ) (a : α), n + 1,
  transitivity list.foldl f 0 ys,
  { generalize : 0 = n,
    induction ys with _ _ ih generalizing n,
    { simp only [list.foldl_nil] },
    { simp only [list.foldl, ih (n+1)] } },
  { induction ys with _ tl ih,
    { simp only [list.length, list.foldl_nil] },
    { simp only [list.foldl, list.length],
      rw [← ih],
      exact tl.foldl_hom (λx, x+1) f f 0 (λ n x, rfl) } }
end

variables {m : Type u → Type u} [monad m] [is_lawful_monad m]

section
local attribute [semireducible] opposite
lemma mfoldl_to_list {f : α → β → m α} {x : α} {xs : t β} :
  mfoldl f x xs = list.mfoldl f x (to_list xs) :=
begin
  change _ = unop (mfoldl.of_free_monoid f (to_list xs)) x,
  simp only [mfoldl, to_list_spec, fold_map_hom_free (mfoldl.of_free_monoid f),
    mfoldl.of_free_monoid_comp_free_mk, mfoldl.get]
end
end

lemma mfoldr_to_list (f : α → β → m β) (x : β) (xs : t α) :
  mfoldr f x xs = list.mfoldr f x (to_list xs) :=
begin
  change _ = mfoldr.of_free_monoid f (to_list xs) x,
  simp only [mfoldr, to_list_spec, fold_map_hom_free (mfoldr.of_free_monoid f),
    mfoldr.of_free_monoid_comp_free_mk, mfoldr.get]
end

@[simp] theorem mfoldl_map (g : β → γ) (f : α → γ → m α) (a : α) (l : t β) :
  mfoldl f a (g <$> l) = mfoldl (λ x y, f x (g y)) a l :=
by simp only [mfoldl, fold_map_map, (∘), flip]

@[simp] theorem mfoldr_map (g : β → γ) (f : γ → α → m α) (a : α) (l : t β) :
  mfoldr f a (g <$> l) = mfoldr (f ∘ g) a l :=
by simp only [mfoldr, fold_map_map, (∘), flip]

end equalities

end traversable