/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.Lean3Lib.data.stream
import Mathlib.Lean3Lib.data.lazy_list
import Mathlib.data.seq.computation
import Mathlib.PostPort

universes u u_1 v w

namespace Mathlib

/-
coinductive seq (α : Type u) : Type u
| nil : seq α
| cons : α → seq α → seq α
-/

/--
A stream `s : option α` is a sequence if `s.nth n = none` implies `s.nth (n + 1) = none`.
-/
def stream.is_seq {α : Type u} (s : stream (Option α)) := ∀ {n : ℕ}, s n = none → s (n + 1) = none

/-- `seq α` is the type of possibly infinite lists (referred here as sequences).
  It is encoded as an infinite stream of options such that if `f n = none`, then
  `f m = none` for all `m ≥ n`. -/
def seq (α : Type u) := Subtype fun (f : stream (Option α)) => stream.is_seq f

/-- `seq1 α` is the type of nonempty sequences. -/
def seq1 (α : Type u_1) := α × seq α

namespace seq

/-- The empty sequence -/
def nil {α : Type u} : seq α := { val := stream.const none, property := sorry }

protected instance inhabited {α : Type u} : Inhabited (seq α) := { default := nil }

/-- Prepend an element to a sequence -/
def cons {α : Type u} (a : α) : seq α → seq α := sorry

/-- Get the nth element of a sequence (if it exists) -/
def nth {α : Type u} : seq α → ℕ → Option α := subtype.val

/-- A sequence has terminated at position `n` if the value at position `n` equals `none`. -/
def terminated_at {α : Type u} (s : seq α) (n : ℕ) := nth s n = none

/-- It is decidable whether a sequence terminates at a given position. -/
protected instance terminated_at_decidable {α : Type u} (s : seq α) (n : ℕ) :
    Decidable (terminated_at s n) :=
  decidable_of_iff' ↥(option.is_none (nth s n)) sorry

/-- A sequence terminates if there is some position `n` at which it has terminated. -/
def terminates {α : Type u} (s : seq α) := ∃ (n : ℕ), terminated_at s n

/-- Functorial action of the functor `option (α × _)` -/
@[simp] def omap {α : Type u} {β : Type v} {γ : Type w} (f : β → γ) :
    Option (α × β) → Option (α × γ) :=
  sorry

/-- Get the first element of a sequence -/
def head {α : Type u} (s : seq α) : Option α := nth s 0

/-- Get the tail of a sequence (or `nil` if the sequence is `nil`) -/
def tail {α : Type u} : seq α → seq α := sorry

protected def mem {α : Type u} (a : α) (s : seq α) := some a ∈ subtype.val s

protected instance has_mem {α : Type u} : has_mem α (seq α) := has_mem.mk seq.mem

theorem le_stable {α : Type u} (s : seq α) {m : ℕ} {n : ℕ} (h : m ≤ n) :
    nth s m = none → nth s n = none :=
  sorry

/-- If a sequence terminated at position `n`, it also terminated at `m ≥ n `. -/
theorem terminated_stable {α : Type u} (s : seq α) {m : ℕ} {n : ℕ} (m_le_n : m ≤ n)
    (terminated_at_m : terminated_at s m) : terminated_at s n :=
  le_stable s m_le_n terminated_at_m

/--
If `s.nth n = some aₙ` for some value `aₙ`, then there is also some value `aₘ` such
that `s.nth = some aₘ` for `m ≤ n`.
-/
theorem ge_stable {α : Type u} (s : seq α) {aₙ : α} {n : ℕ} {m : ℕ} (m_le_n : m ≤ n)
    (s_nth_eq_some : nth s n = some aₙ) : ∃ (aₘ : α), nth s m = some aₘ :=
  sorry

theorem not_mem_nil {α : Type u} (a : α) : ¬a ∈ nil := sorry

theorem mem_cons {α : Type u} (a : α) (s : seq α) : a ∈ cons a s :=
  subtype.cases_on s
    fun (s_val : stream (Option α)) (s_property : stream.is_seq s_val) =>
      idRhs (some a ∈ some a :: s_val) (stream.mem_cons (some a) s_val)

theorem mem_cons_of_mem {α : Type u} (y : α) {a : α} {s : seq α} : a ∈ s → a ∈ cons y s := sorry

theorem eq_or_mem_of_mem_cons {α : Type u} {a : α} {b : α} {s : seq α} :
    a ∈ cons b s → a = b ∨ a ∈ s :=
  sorry

@[simp] theorem mem_cons_iff {α : Type u} {a : α} {b : α} {s : seq α} :
    a ∈ cons b s ↔ a = b ∨ a ∈ s :=
  sorry

/-- Destructor for a sequence, resulting in either `none` (for `nil`) or
  `some (a, s)` (for `cons a s`). -/
def destruct {α : Type u} (s : seq α) : Option (seq1 α) :=
  (fun (a' : α) => (a', tail s)) <$> nth s 0

theorem destruct_eq_nil {α : Type u} {s : seq α} : destruct s = none → s = nil := sorry

theorem destruct_eq_cons {α : Type u} {s : seq α} {a : α} {s' : seq α} :
    destruct s = some (a, s') → s = cons a s' :=
  sorry

@[simp] theorem destruct_nil {α : Type u} : destruct nil = none := rfl

@[simp] theorem destruct_cons {α : Type u} (a : α) (s : seq α) :
    destruct (cons a s) = some (a, s) :=
  sorry

theorem head_eq_destruct {α : Type u} (s : seq α) : head s = prod.fst <$> destruct s := sorry

@[simp] theorem head_nil {α : Type u} : head nil = none := rfl

@[simp] theorem head_cons {α : Type u} (a : α) (s : seq α) : head (cons a s) = some a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (head (cons a s) = some a)) (head_eq_destruct (cons a s))))
    (eq.mpr
      (id (Eq._oldrec (Eq.refl (prod.fst <$> destruct (cons a s) = some a)) (destruct_cons a s)))
      (Eq.refl (prod.fst <$> some (a, s))))

@[simp] theorem tail_nil {α : Type u} : tail nil = nil := rfl

@[simp] theorem tail_cons {α : Type u} (a : α) (s : seq α) : tail (cons a s) = s := sorry

def cases_on {α : Type u} {C : seq α → Sort v} (s : seq α) (h1 : C nil)
    (h2 : (x : α) → (s : seq α) → C (cons x s)) : C s :=
  (fun (_x : Option (seq1 α)) (H : destruct s = _x) =>
      Option.rec (fun (H : destruct s = none) => eq.mpr sorry h1)
        (fun (v : seq1 α) (H : destruct s = some v) =>
          prod.cases_on v
            (fun (a : α) (s' : seq α) (H : destruct s = some (a, s')) => eq.mpr sorry (h2 a s')) H)
        _x H)
    (destruct s) sorry

theorem mem_rec_on {α : Type u} {C : seq α → Prop} {a : α} {s : seq α} (M : a ∈ s)
    (h1 : ∀ (b : α) (s' : seq α), a = b ∨ C s' → C (cons b s')) : C s :=
  sorry

def corec.F {α : Type u} {β : Type v} (f : β → Option (α × β)) : Option β → Option α × Option β :=
  sorry

/-- Corecursor for `seq α` as a coinductive type. Iterates `f` to produce new elements
  of the sequence until `none` is obtained. -/
def corec {α : Type u} {β : Type v} (f : β → Option (α × β)) (b : β) : seq α :=
  { val := stream.corec' sorry (some b), property := sorry }

@[simp] theorem corec_eq {α : Type u} {β : Type v} (f : β → Option (α × β)) (b : β) :
    destruct (corec f b) = omap (corec f) (f b) :=
  sorry

/-- Embed a list as a sequence -/
def of_list {α : Type u} (l : List α) : seq α := { val := list.nth l, property := sorry }

protected instance coe_list {α : Type u} : has_coe (List α) (seq α) := has_coe.mk of_list

@[simp] def bisim_o {α : Type u} (R : seq α → seq α → Prop) :
    Option (seq1 α) → Option (seq1 α) → Prop :=
  sorry

def is_bisimulation {α : Type u} (R : seq α → seq α → Prop) :=
  ∀ {s₁ s₂ : seq α}, R s₁ s₂ → bisim_o R (destruct s₁) (destruct s₂)

theorem eq_of_bisim {α : Type u} (R : seq α → seq α → Prop) (bisim : is_bisimulation R) {s₁ : seq α}
    {s₂ : seq α} (r : R s₁ s₂) : s₁ = s₂ :=
  sorry

theorem coinduction {α : Type u} {s₁ : seq α} {s₂ : seq α} :
    head s₁ = head s₂ →
        (∀ (β : Type u) (fr : seq α → β), fr s₁ = fr s₂ → fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ :=
  sorry

theorem coinduction2 {α : Type u} {β : Type v} (s : seq α) (f : seq α → seq β) (g : seq α → seq β)
    (H :
      ∀ (s : seq α),
        bisim_o (fun (s1 s2 : seq β) => ∃ (s : seq α), s1 = f s ∧ s2 = g s) (destruct (f s))
          (destruct (g s))) :
    f s = g s :=
  sorry

/-- Embed an infinite stream as a sequence -/
def of_stream {α : Type u} (s : stream α) : seq α := { val := stream.map some s, property := sorry }

protected instance coe_stream {α : Type u} : has_coe (stream α) (seq α) := has_coe.mk of_stream

/-- Embed a `lazy_list α` as a sequence. Note that even though this
  is non-meta, it will produce infinite sequences if used with
  cyclic `lazy_list`s created by meta constructions. -/
def of_lazy_list {α : Type u} : lazy_list α → seq α := corec fun (l : lazy_list α) => sorry

protected instance coe_lazy_list {α : Type u} : has_coe (lazy_list α) (seq α) :=
  has_coe.mk of_lazy_list

/-- Translate a sequence into a `lazy_list`. Since `lazy_list` and `list`
  are isomorphic as non-meta types, this function is necessarily meta. -/
/-- Translate a sequence to a list. This function will run forever if
  run on an infinite sequence. -/
/-- The sequence of natural numbers some 0, some 1, ... -/
def nats : seq ℕ := ↑stream.nats

@[simp] theorem nats_nth (n : ℕ) : nth nats n = some n := rfl

/-- Append two sequences. If `s₁` is infinite, then `s₁ ++ s₂ = s₁`,
  otherwise it puts `s₂` at the location of the `nil` in `s₁`. -/
def append {α : Type u} (s₁ : seq α) (s₂ : seq α) : seq α :=
  corec (fun (_x : seq α × seq α) => sorry) (s₁, s₂)

/-- Map a function over a sequence. -/
def map {α : Type u} {β : Type v} (f : α → β) : seq α → seq β := sorry

/-- Flatten a sequence of sequences. (It is required that the
  sequences be nonempty to ensure productivity; in the case
  of an infinite sequence of `nil`, the first element is never
  generated.) -/
def join {α : Type u} : seq (seq1 α) → seq α := corec fun (S : seq (seq1 α)) => sorry

/-- Remove the first `n` elements from the sequence. -/
@[simp] def drop {α : Type u} (s : seq α) : ℕ → seq α := sorry

/-- Take the first `n` elements of the sequence (producing a list) -/
def take {α : Type u} : ℕ → seq α → List α := sorry

/-- Split a sequence at `n`, producing a finite initial segment
  and an infinite tail. -/
def split_at {α : Type u} : ℕ → seq α → List α × seq α := sorry

/-- Combine two sequences with a function -/
def zip_with {α : Type u} {β : Type v} {γ : Type w} (f : α → β → γ) : seq α → seq β → seq γ := sorry

theorem zip_with_nth_some {α : Type u} {β : Type v} {γ : Type w} {s : seq α} {s' : seq β} {n : ℕ}
    {a : α} {b : β} (s_nth_eq_some : nth s n = some a) (s_nth_eq_some' : nth s' n = some b)
    (f : α → β → γ) : nth (zip_with f s s') n = some (f a b) :=
  sorry

theorem zip_with_nth_none {α : Type u} {β : Type v} {γ : Type w} {s : seq α} {s' : seq β} {n : ℕ}
    (s_nth_eq_none : nth s n = none) (f : α → β → γ) : nth (zip_with f s s') n = none :=
  sorry

theorem zip_with_nth_none' {α : Type u} {β : Type v} {γ : Type w} {s : seq α} {s' : seq β} {n : ℕ}
    (s'_nth_eq_none : nth s' n = none) (f : α → β → γ) : nth (zip_with f s s') n = none :=
  sorry

/-- Pair two sequences into a sequence of pairs -/
def zip {α : Type u} {β : Type v} : seq α → seq β → seq (α × β) := zip_with Prod.mk

/-- Separate a sequence of pairs into two sequences -/
def unzip {α : Type u} {β : Type v} (s : seq (α × β)) : seq α × seq β :=
  (map prod.fst s, map prod.snd s)

/-- Convert a sequence which is known to terminate into a list -/
def to_list {α : Type u} (s : seq α) (h : ∃ (n : ℕ), ¬↥(option.is_some (nth s n))) : List α :=
  take (nat.find h) s

/-- Convert a sequence which is known not to terminate into a stream -/
def to_stream {α : Type u} (s : seq α) (h : ∀ (n : ℕ), ↥(option.is_some (nth s n))) : stream α :=
  fun (n : ℕ) => option.get (h n)

/-- Convert a sequence into either a list or a stream depending on whether
  it is finite or infinite. (Without decidability of the infiniteness predicate,
  this is not constructively possible.) -/
def to_list_or_stream {α : Type u} (s : seq α)
    [Decidable (∃ (n : ℕ), ¬↥(option.is_some (nth s n)))] : List α ⊕ stream α :=
  dite (∃ (n : ℕ), ¬↥(option.is_some (nth s n)))
    (fun (h : ∃ (n : ℕ), ¬↥(option.is_some (nth s n))) => sum.inl (to_list s h))
    fun (h : ¬∃ (n : ℕ), ¬↥(option.is_some (nth s n))) => sum.inr (to_stream s sorry)

@[simp] theorem nil_append {α : Type u} (s : seq α) : append nil s = s := sorry

@[simp] theorem cons_append {α : Type u} (a : α) (s : seq α) (t : seq α) :
    append (cons a s) t = cons a (append s t) :=
  sorry

@[simp] theorem append_nil {α : Type u} (s : seq α) : append s nil = s := sorry

@[simp] theorem append_assoc {α : Type u} (s : seq α) (t : seq α) (u : seq α) :
    append (append s t) u = append s (append t u) :=
  sorry

@[simp] theorem map_nil {α : Type u} {β : Type v} (f : α → β) : map f nil = nil := rfl

@[simp] theorem map_cons {α : Type u} {β : Type v} (f : α → β) (a : α) (s : seq α) :
    map f (cons a s) = cons (f a) (map f s) :=
  sorry

@[simp] theorem map_id {α : Type u} (s : seq α) : map id s = s := sorry

@[simp] theorem map_tail {α : Type u} {β : Type v} (f : α → β) (s : seq α) :
    map f (tail s) = tail (map f s) :=
  sorry

theorem map_comp {α : Type u} {β : Type v} {γ : Type w} (f : α → β) (g : β → γ) (s : seq α) :
    map (g ∘ f) s = map g (map f s) :=
  sorry

@[simp] theorem map_append {α : Type u} {β : Type v} (f : α → β) (s : seq α) (t : seq α) :
    map f (append s t) = append (map f s) (map f t) :=
  sorry

@[simp] theorem map_nth {α : Type u} {β : Type v} (f : α → β) (s : seq α) (n : ℕ) :
    nth (map f s) n = option.map f (nth s n) :=
  sorry

protected instance functor : Functor seq :=
  { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β }

protected instance is_lawful_functor : is_lawful_functor seq := is_lawful_functor.mk map_id map_comp

@[simp] theorem join_nil {α : Type u} : join nil = nil := destruct_eq_nil rfl

@[simp] theorem join_cons_nil {α : Type u} (a : α) (S : seq (seq1 α)) :
    join (cons (a, nil) S) = cons a (join S) :=
  sorry

@[simp] theorem join_cons_cons {α : Type u} (a : α) (b : α) (s : seq α) (S : seq (seq1 α)) :
    join (cons (a, cons b s) S) = cons a (join (cons (b, s) S)) :=
  sorry

@[simp] theorem join_cons {α : Type u} (a : α) (s : seq α) (S : seq (seq1 α)) :
    join (cons (a, s) S) = cons a (append s (join S)) :=
  sorry

@[simp] theorem join_append {α : Type u} (S : seq (seq1 α)) (T : seq (seq1 α)) :
    join (append S T) = append (join S) (join T) :=
  sorry

@[simp] theorem of_list_nil {α : Type u} : of_list [] = nil := rfl

@[simp] theorem of_list_cons {α : Type u} (a : α) (l : List α) :
    of_list (a :: l) = cons a (of_list l) :=
  sorry

@[simp] theorem of_stream_cons {α : Type u} (a : α) (s : stream α) :
    of_stream (a :: s) = cons a (of_stream s) :=
  sorry

@[simp] theorem of_list_append {α : Type u} (l : List α) (l' : List α) :
    of_list (l ++ l') = append (of_list l) (of_list l') :=
  sorry

@[simp] theorem of_stream_append {α : Type u} (l : List α) (s : stream α) :
    of_stream (l++ₛs) = append (of_list l) (of_stream s) :=
  sorry

/-- Convert a sequence into a list, embedded in a computation to allow for
  the possibility of infinite sequences (in which case the computation
  never returns anything). -/
def to_list' {α : Type u_1} (s : seq α) : computation (List α) :=
  computation.corec (fun (_x : List α × seq α) => sorry) ([], s)

theorem dropn_add {α : Type u} (s : seq α) (m : ℕ) (n : ℕ) : drop s (m + n) = drop (drop s m) n :=
  sorry

theorem dropn_tail {α : Type u} (s : seq α) (n : ℕ) : drop (tail s) n = drop s (n + 1) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (drop (tail s) n = drop s (n + 1))) (add_comm n 1)))
    (Eq.symm (dropn_add s 1 n))

theorem nth_tail {α : Type u} (s : seq α) (n : ℕ) : nth (tail s) n = nth s (n + 1) := sorry

protected theorem ext {α : Type u} (s : seq α) (s' : seq α) (hyp : ∀ (n : ℕ), nth s n = nth s' n) :
    s = s' :=
  sorry

@[simp] theorem head_dropn {α : Type u} (s : seq α) (n : ℕ) : head (drop s n) = nth s n := sorry

theorem mem_map {α : Type u} {β : Type v} (f : α → β) {a : α} {s : seq α} : a ∈ s → f a ∈ map f s :=
  sorry

theorem exists_of_mem_map {α : Type u} {β : Type v} {f : α → β} {b : β} {s : seq α} :
    b ∈ map f s → ∃ (a : α), a ∈ s ∧ f a = b :=
  sorry

theorem of_mem_append {α : Type u} {s₁ : seq α} {s₂ : seq α} {a : α} (h : a ∈ append s₁ s₂) :
    a ∈ s₁ ∨ a ∈ s₂ :=
  sorry

theorem mem_append_left {α : Type u} {s₁ : seq α} {s₂ : seq α} {a : α} (h : a ∈ s₁) :
    a ∈ append s₁ s₂ :=
  sorry

end seq

namespace seq1

/-- Convert a `seq1` to a sequence. -/
def to_seq {α : Type u} : seq1 α → seq α := sorry

protected instance coe_seq {α : Type u} : has_coe (seq1 α) (seq α) := has_coe.mk to_seq

/-- Map a function on a `seq1` -/
def map {α : Type u} {β : Type v} (f : α → β) : seq1 α → seq1 β := sorry

theorem map_id {α : Type u} (s : seq1 α) : map id s = s := sorry

/-- Flatten a nonempty sequence of nonempty sequences -/
def join {α : Type u} : seq1 (seq1 α) → seq1 α := sorry

@[simp] theorem join_nil {α : Type u} (a : α) (S : seq (seq1 α)) :
    join ((a, seq.nil), S) = (a, seq.join S) :=
  rfl

@[simp] theorem join_cons {α : Type u} (a : α) (b : α) (s : seq α) (S : seq (seq1 α)) :
    join ((a, seq.cons b s), S) = (a, seq.join (seq.cons (b, s) S)) :=
  sorry

/-- The `return` operator for the `seq1` monad,
  which produces a singleton sequence. -/
def ret {α : Type u} (a : α) : seq1 α := (a, seq.nil)

protected instance inhabited {α : Type u} [Inhabited α] : Inhabited (seq1 α) :=
  { default := ret Inhabited.default }

/-- The `bind` operator for the `seq1` monad,
  which maps `f` on each element of `s` and appends the results together.
  (Not all of `s` may be evaluated, because the first few elements of `s`
  may already produce an infinite result.) -/
def bind {α : Type u} {β : Type v} (s : seq1 α) (f : α → seq1 β) : seq1 β := join (map f s)

@[simp] theorem join_map_ret {α : Type u} (s : seq α) : seq.join (seq.map ret s) = s := sorry

@[simp] theorem bind_ret {α : Type u} {β : Type v} (f : α → β) (s : seq1 α) :
    bind s (ret ∘ f) = map f s :=
  sorry

@[simp] theorem ret_bind {α : Type u} {β : Type v} (a : α) (f : α → seq1 β) :
    bind (ret a) f = f a :=
  sorry

@[simp] theorem map_join' {α : Type u} {β : Type v} (f : α → β) (S : seq (seq1 α)) :
    seq.map f (seq.join S) = seq.join (seq.map (map f) S) :=
  sorry

@[simp] theorem map_join {α : Type u} {β : Type v} (f : α → β) (S : seq1 (seq1 α)) :
    map f (join S) = join (map (map f) S) :=
  sorry

@[simp] theorem join_join {α : Type u} (SS : seq (seq1 (seq1 α))) :
    seq.join (seq.join SS) = seq.join (seq.map join SS) :=
  sorry

@[simp] theorem bind_assoc {α : Type u} {β : Type v} {γ : Type w} (s : seq1 α) (f : α → seq1 β)
    (g : β → seq1 γ) : bind (bind s f) g = bind s fun (x : α) => bind (f x) g :=
  sorry

protected instance monad : Monad seq1 :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β },
        toPure := { pure := ret },
        toSeq :=
          { seq :=
              fun (α β : Type u_1) (f : seq1 (α → β)) (x : seq1 α) =>
                bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : seq1 α) (b : seq1 β) =>
                (fun (α β : Type u_1) (f : seq1 (α → β)) (x : seq1 α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β α (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : seq1 α) (b : seq1 β) =>
                (fun (α β : Type u_1) (f : seq1 (α → β)) (x : seq1 α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β β (map (function.const α id) a) b } },
    toBind := { bind := bind } }

protected instance is_lawful_monad : is_lawful_monad seq1 := is_lawful_monad.mk ret_bind bind_assoc

end Mathlib


/-
Copyright (c) 2017 Gabriel Ebner, Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Floris van Doorn

Declaration of the primitive hits in Lean
-/
import .trunc .pathover .meta.induction

universes u v w l
hott_theory

namespace hott
open is_trunc eq

/-
  We take two higher inductive types (hits) as primitive notions in Lean. We define all other hits
  in terms of these two hits. The hits which are primitive are
    - n-truncation
    - quotients (not truncated)
  For each of the hits we add the following constants:
    - the type formation
    - the term and path constructors
    - the dependent recursor

  Both HITs are essentially newtypes that impose an additional restriction on
  the minor premise in the eliminator.  We implement these types without
  modifying the kernel.  For each type, we define a private structure with
  unrestricted eliminator.  We then define the correct recursor on top, and
  manually add the path constructors axiomatically.  There are two protections
  against use of the internal (unsound) eliminator: 1) it is private, 2) it
  is marked with [nothott] so that the HoTT checker rejects it.

  In this file we only define the dependent recursor. For the nondependent recursor and all other
  uses of these hits, see the folder ../hit/
-/

private structure trunc_impl (n : ℕ₋₂) (A : Type u) : Type u :=
(a : A)

@[hott] def trunc (n : ℕ₋₂) (A : Type u) : Type u :=
trunc_impl n A

namespace trunc
  @[hott] def tr {n : ℕ₋₂} {A : Type u} (a : A) : trunc n A :=
  trunc_impl.mk n a

  @[hott] axiom is_trunc_trunc (n : ℕ₋₂) (A : Type u) : is_trunc n (trunc n A)
  attribute [instance] is_trunc_trunc

  @[hott, induction, priority 1000] protected def rec {n : ℕ₋₂} {A : Type u} {P : trunc n A → Type v}
    [Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) (aa : trunc n A) : P aa :=
  (match aa with ⟨_, a⟩ := ⟨Pt, H _⟩ end : _ × P aa).snd

  attribute [nothott] trunc_impl.rec
  attribute [irreducible] trunc

  @[hott, hsimp, reducible, elab_as_eliminator] protected definition rec_on {n : ℕ₋₂} {A : Type u}
    {P : trunc n A → Type v} (aa : trunc n A) [Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a))
    : P aa :=
  trunc.rec H aa
end trunc

private structure quotient_impl {A : Type u} (R : A → A → Type v) : Type (max u v) :=
(a : A)

@[hott] def quotient {A : Type u} (R : A → A → Type v) : Type (max u v) :=
quotient_impl R

namespace quotient

  @[hott] def class_of {A : Type u} (R : A → A → Type v) (a : A) : quotient R :=
  quotient_impl.mk R a

  @[hott] axiom eq_of_rel {A : Type u} (R : A → A → Type v) ⦃a a' : A⦄ (H : R a a')
    : class_of R a = class_of R a'

  @[hott, induction, priority 1000] protected def rec {A : Type u} {R : A → A → Type v} {P : quotient R → Type w}
    (Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a')
    (x : quotient R) : P x :=
  (match x with ⟨_, a⟩ := ⟨Pp, Pc a⟩ end : _ × P x).snd

  attribute [nothott] quotient_impl.rec
  attribute [irreducible] quotient

  @[hott, hsimp, reducible, elab_as_eliminator] protected def rec_on {A : Type u} {R : A → A → Type v} {P : quotient R → Type w}
    (x : quotient R) (Pc : Π(a : A), P (class_of R a))
    (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a') : P x :=
  quotient.rec Pc Pp x

end quotient

namespace trunc
  @[hott, hsimp] def rec_tr {n : ℕ₋₂} {A : Type u} {P : trunc n A → Type v}
    [Pt : Πaa, is_trunc n (P aa)] (H : Πa, P (tr a)) (a : A) : trunc.rec H (tr a) = H a :=
  idp

  -- Make sure that the `Pt` argument is relevant in def-eq comparison
  open tactic
  local attribute [reducible] trunc
  example {n : ℕ₋₂} {A : Type u} {P : trunc n A → Type v} (Pt Pt') (H aa) :
    @trunc.rec _ _ P Pt H aa = @trunc.rec _ _ P Pt' H aa :=
  begin
    success_if_fail { refl },
    cases aa, refl, -- non-HoTT proof so that example doesn't fail
  end
end trunc

namespace quotient
  @[hott, hsimp] def rec_class_of {A : Type u} {R : A → A → Type v} {P : quotient R → Type w}
    (Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a')
    (a : A) : quotient.rec Pc Pp (class_of R a) = Pc a :=
  idp

  @[hott] constant rec_eq_of_rel {A : Type u} {R : A → A → Type v} {P : quotient R → Type w}
    (Pc : Π(a : A), P (class_of R a)) (Pp : Π⦃a a' : A⦄ (H : R a a'), Pc a =[eq_of_rel R H] Pc a')
    {a a' : A} (H : R a a') : apd (quotient.rec Pc Pp) (eq_of_rel R H) = Pp H

  -- Make sure that the `Pp` argument is relevant in def-eq comparison
  open tactic
  local attribute [reducible] quotient
  example {A : Type u} {R : A → A → Type v} {P : quotient R → Type w}
        (Pc : Π(a : A), P (class_of R a)) (Pp Pp' x) :
    quotient.rec Pc Pp x = quotient.rec Pc Pp' x :=
  begin
    success_if_fail { refl },
    cases x, refl, -- non-HoTT proof so that example doesn't fail
  end
end quotient

end hott


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import order.category.Lattice

/-!
# Category of linear orders

This defines `LinearOrder`, the category of linear orders with monotone maps.
-/

open category_theory

universe u

/-- The category of linear orders. -/
def LinearOrder := bundled linear_order

namespace LinearOrder

instance : bundled_hom.parent_projection @linear_order.to_partial_order := ⟨⟩

attribute [derive [large_category, concrete_category]] LinearOrder

instance : has_coe_to_sort LinearOrder Type* := bundled.has_coe_to_sort

/-- Construct a bundled `LinearOrder` from the underlying type and typeclass. -/
def of (α : Type*) [linear_order α] : LinearOrder := bundled.of α

@[simp] lemma coe_of (α : Type*) [linear_order α] : ↥(of α) = α := rfl

instance : inhabited LinearOrder := ⟨of punit⟩

instance (α : LinearOrder) : linear_order α := α.str

instance has_forget_to_Lattice : has_forget₂ LinearOrder Lattice :=
{ forget₂ := { obj := λ X, Lattice.of X,
               map := λ X Y f, (order_hom_class.to_lattice_hom X Y f : lattice_hom X Y) } }

/-- Constructs an equivalence between linear orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : LinearOrder.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : LinearOrder ⥤ LinearOrder :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `LinearOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : LinearOrder ≌ LinearOrder :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end LinearOrder

lemma LinearOrder_dual_comp_forget_to_Lattice :
  LinearOrder.dual ⋙ forget₂ LinearOrder Lattice = forget₂ LinearOrder Lattice ⋙ Lattice.dual :=
rfl


/-
  Continuous maps and presheaves of rings.

  https://stacks.math.columbia.edu/tag/008C
-/

import to_mathlib.opens
import sheaves.presheaf_of_rings
import sheaves.stalk_of_rings
import sheaves.presheaf_maps

universes u v w

open topological_space

variables {α : Type u} [topological_space α]
variables {β : Type v} [topological_space β]

namespace presheaf_of_rings

-- f induces a functor PSh(α) ⟶ PSh(β).

section pushforward

variables {f : α → β} (Hf : continuous f)

def pushforward (F : presheaf_of_rings α) : presheaf_of_rings β :=
{ Fring := λ U, F.Fring _,
  res_is_ring_hom := λ U V HVU, F.res_is_ring_hom _ _ _,
  ..presheaf.pushforward Hf F.to_presheaf }

def pushforward.morphism (F G : presheaf_of_rings α) (φ : F ⟶ G)
: pushforward Hf F ⟶ pushforward Hf G :=
{ ring_homs := λ U, φ.ring_homs _,
  ..presheaf.pushforward.morphism Hf F.to_presheaf G.to_presheaf φ.to_morphism }

end pushforward

-- f induces a functor PSh(β) ⟶ PSh(α). Simplified to the case when f is 'nice'.

section pullback

variable (α)

structure open_immersion_pullback (F : presheaf_of_rings β) :=
(f       : α → β)
-- Open immersion. TODO: Use open embedding.
(Hf₁     : continuous f)
(Hf₂     : ∀ (U : opens α), is_open (f '' U))
(Hf₃     : function.injective f)
(range   : opens β := ⟨f '' set.univ, Hf₂ opens.univ⟩)
(carrier : presheaf_of_rings α :=
  { Fring := λ U, F.Fring _,
    res_is_ring_hom := λ U V HVU, F.res_is_ring_hom _ _ _,
    ..presheaf.pullback Hf₂ F.to_presheaf })

def pullback_id (F : presheaf_of_rings β) : open_immersion_pullback β F :=
begin
  exact
    { f := (id : β → β),
      Hf₁ := continuous_id,
      Hf₂ := λ U, by rw set.image_id; by exact U.2,
      Hf₃ := function.injective_id },
  exact F,
end

lemma pullback_id.iso (F : presheaf_of_rings β) : (pullback_id F).carrier ≅ F :=
nonempty.intro
{ mor :=
    { map :=
      begin
        intros U,
        have HUU : U ⊆ opens.map (pullback_id F).Hf₂ U,
          intros x Hx,
          dsimp [opens.map],
          erw set.image_id,
          exact Hx,
        exact F.res (opens.map (pullback_id F).Hf₂ U) U HUU,
      end,
    commutes :=
      begin
        intros U V HVU,
        dsimp [pullback_id],
        rw ←presheaf.Hcomp,
        rw ←presheaf.Hcomp,
      end,
    ring_homs := by apply_instance, },
  inv :=
    { map :=
        begin
          intros U,
          have HUU : opens.map (pullback_id F).Hf₂ U ⊆ U,
            intros x Hx,
            dsimp [opens.map] at Hx,
            erw set.image_id at Hx,
            exact Hx,
          exact F.res U (opens.map (pullback_id F).Hf₂ U) HUU,
        end,
      commutes :=
        begin
          intros U V HVU,
          dsimp [pullback_id],
          rw ←presheaf.Hcomp,
          rw ←presheaf.Hcomp,
        end,
      ring_homs := by apply_instance, },
  mor_inv_id :=
    begin
      simp [presheaf.comp],
      congr,
      funext U,
      rw ←presheaf.Hcomp,
      erw presheaf.Hid,
    end,
  inv_mor_id :=
    begin
      simp [presheaf.comp],
      congr,
      funext U,
      rw ←presheaf.Hcomp,
      erw presheaf.Hid,
    end, }

end pullback

-- f induces a `map` from a presheaf of rings on β to a presheaf of rings on α.

variable {α}

variables {f : α → β} (Hf : continuous f)

def fmap (F : presheaf_of_rings α) (G : presheaf_of_rings β) :=
presheaf.fmap Hf F.to_presheaf G.to_presheaf

namespace fmap

variables {γ : Type w} [topological_space γ]
variables {g : β → γ} {Hg : continuous g}

variable {Hf}

def comp {F : presheaf_of_rings α} {G : presheaf_of_rings β} {H : presheaf_of_rings γ}
(f_ : fmap Hf F G) (g_ : fmap Hg G H) : fmap (continuous.comp Hg Hf) F H :=
presheaf.fmap.comp f_ g_

def induced
(F : presheaf_of_rings α) (G : presheaf_of_rings β)
(f' : fmap Hf F G) (x : α)
: stalk_of_rings G (f x) → stalk_of_rings F x :=
presheaf.fmap.induced F.to_presheaf G.to_presheaf f' x

end fmap

end presheaf_of_rings


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro, Johannes Hölzl
-/
import algebra.order.group.instances
import algebra.order.monoid.with_top

/-!
# Adjoining a top element to a `linear_ordered_add_comm_group_with_top`.

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

variable {α : Type*}

section linear_ordered_add_comm_group
variables [linear_ordered_add_comm_group α] {a b c d : α}

instance with_top.linear_ordered_add_comm_group_with_top :
  linear_ordered_add_comm_group_with_top (with_top α) :=
{ neg            := option.map (λ a : α, -a),
  neg_top        := @option.map_none _ _ (λ a : α, -a),
  add_neg_cancel := begin
    rintro (a | a) ha,
    { exact (ha rfl).elim },
    { exact with_top.coe_add.symm.trans (with_top.coe_eq_coe.2 (add_neg_self a)) }
  end,
  .. with_top.linear_ordered_add_comm_monoid_with_top,
  .. option.nontrivial }

@[simp, norm_cast]
lemma with_top.coe_neg (a : α) : ((-a : α) : with_top α) = -a := rfl

end linear_ordered_add_comm_group


import number_theory.arithmetic_function
import algebra.squarefree
import algebra.order.floor
import data.list.intervals
import tactic
import measure_theory.integral.interval_integral
import general
import archive
import defs
import summability
import squarefree_rw
import lemmas_on_asymptotics
import integral_facts

noncomputable theory
open nat finset function filter
open_locale topological_space interval big_operators filter asymptotics arithmetic_function

namespace squarefree_sums

--------------------------------------------
--           THEOREM 2: THE BIG BAD
--------------------------------------------

lemma one_le_sqrt {n : ℕ} (hn : n ≠ 0) : 1 ≤ sqrt n :=
begin
  have : 1 ≤ n, exact one_le_iff_ne_zero.mpr hn,
  rw ← sqrt_one,
  exact sqrt_le_sqrt this,
end

lemma step0 :
∀ (x : ℕ),
∑ n in finset.Icc 1 x, squarefree_nat n =
∑ n in finset.Icc 1 x, ∑ d in finset.Icc 1 n, ite (d ^ 2 ∣ n) (μ d) 0
:=
begin
  rw squarefree_nat_eq_tμ,
  intros x,
  congr,
  funext n,
  exact rw_tμ,
end

lemma step05 :
∀ (x : ℕ),
∑ n in finset.Icc 1 x, ∑ d in finset.Icc 1 n, ite (d ^ 2 ∣ n) (μ d) 0 =
∑ n in finset.Icc 1 x, ∑ d in finset.Icc 1 x, ite (d ^ 2 ∣ n) (μ d) 0
:=
begin
  intros x,
  apply finset.sum_congr rfl,
  intros y hy,
  apply sum_subset,
  rw subset_iff,
  intros z hz,
  simp at hy,
  simp at hz,
  simp,
  split,
  exact hz.left,
  calc z ≤ y : hz.right ... ≤ x : hy.right,
  intros z hz hz',
  simp at hy,
  simp at hz,
  simp at hz',
  by_cases h : z = 0, simp [h],
  have h' : 1 ≤ z, linarith,
  have h'' : ¬ (z ^ 2 ∣ y), {
    apply nat.not_dvd_of_pos_of_lt (calc 0 < 1 : by linarith ... ≤ y : hy.left),
    rw pow_two,
    have : y = 1 * y, simp,
    rw this,
    exact mul_lt_mul' h' (hz' h') (by simp) (by linarith),
  },
  simp [h''],
end

def num_divides_upto (d : ℕ) (n : ℕ) := ((finset.Icc 1 n).filter (has_dvd.dvd d)).card

-- Swap the order of summation (the really key point)
lemma step1 :
∀ (x : ℕ),
(∑ n in finset.Icc 1 x, ∑ d in finset.Icc 1 x, ite (d ^ 2 ∣ n) (μ d) 0) =
(∑ d in finset.Icc 1 x, ((μ d) * ((finset.Icc 1 x).filter (has_dvd.dvd (d ^ 2))).card))
:=
begin
  intros x,
  have : ∀ (y : ℕ) (s : finset ℕ), ↑(∑ a in s, 1) * (μ y) = ∑ a in s, (μ y), {
    simp,
  },
  conv {
    to_rhs,
    congr,
    skip,
    funext,
    rw card_eq_sum_ones,
    rw mul_comm,
    rw this,
  },
  rw finset.sum_comm,
  congr,
  funext,
  rw sum_ite,
  simp,
end

-- Rewrite inner sum term as floor ( x / d^2 )
lemma Icc_neighbor {a b c : ℕ} (hab : a ≤ b) (hbc : b + 1 ≤ c) :
  finset.Icc a c = finset.Icc a b ∪ finset.Icc (b + 1) c ∧
  disjoint (finset.Icc a b) (finset.Icc (b + 1) c) :=
begin
  split,
  ext x,
  split,
  simp,
  intros hax hxc,
  simp [hax, hxc],
  by_contradiction H,
  push_neg at H,
  linarith [H],
  simp,
  intros h,
  cases h,
  simp [h.left, h.right],
  linarith,
  simp [h.left, h.right],
  linarith,
  rw disjoint_iff_ne,
  simp,
  intros x hax hxb y hby hyc,
  by_contradiction H,
  rw ← H at hby,
  linarith,
end

lemma num_divides_upto_eq (d n : ℕ) : ((finset.Icc 1 n).filter (has_dvd.dvd d)).card = n.div d :=
begin
  induction n with n hn,
  dec_trivial,
  by_cases hh : n = 0,
  simp [hh],
  by_cases hd : d = 0,
  simp [hd],
  dec_trivial,
  by_cases hd' : d = 1,
  simp [hd'],
  dec_trivial,
  have : 2 ≤ d, exact two_le_nat_iff_not_zero_one.mpr ⟨hd, hd'⟩,
  have : (1 : ℕ).div d = (1 : ℕ) / d, exact rfl,
  rw this,
  have : (1 : ℕ) / d = 0, exact nat.div_eq_zero (by linarith [this]),
  rw this,
  rw card_eq_zero,
  rw eq_empty_iff_forall_not_mem,
  intros x,
  by_contradiction H,
  rw mem_filter at H,
  simp at H,
  rcases H with ⟨aa, bb⟩,
  rw aa at bb,
  have : d = 1, exact nat.dvd_one.mp bb,
  exact hd' this,

  have aaa : 1 ≤ n, exact one_le_iff_ne_zero.mpr hh,
  have bbb : n + 1 ≤ n + 1, linarith,
  have ccc : n.succ = n + 1, exact rfl,

  obtain ⟨is_union, is_disjoint⟩ := Icc_neighbor aaa bbb,
  rw ccc,
  rw is_union,
  rw filter_union,
  rw card_disjoint_union (disjoint_filter_filter is_disjoint),
  rw hn,
  simp,
  have dvd_case : d ∣ n.succ → (finset.filter (has_dvd.dvd d) {n.succ}).card = 1, {
    intros hd,
    rw card_eq_one,
    use n.succ,
    rw finset.eq_singleton_iff_unique_mem,
    split,
    rw finset.mem_filter,
    simp [hd],
    intros x,
    rw finset.mem_filter,
    rintros ⟨hx, hxx⟩,
    exact finset.mem_singleton.mp hx,
  },
  have not_dvd_case : ¬ (d ∣ n.succ) → (finset.filter (has_dvd.dvd d) {n.succ}).card = 0, {
    intros hd,
    rw card_eq_zero,
    rw finset.eq_empty_iff_forall_not_mem,
    intros x,
    rw finset.mem_filter,
    push_neg,
    intros hx,
    rw finset.mem_singleton at hx,
    rwa ← hx at hd,
  },
  by_cases d ∣ n.succ,
  {
    rw dvd_case h,
    have : n.succ.div d = (n + 1) / d, exact rfl,
    rw this,
    rw succ_div,
    have : n.div d = n / d, exact rfl,
    rw this,
    have : n.succ = n + 1, exact rfl,
    rw this at h,
    simp [h],
  },
  {
    rw not_dvd_case h,
    have : n.succ.div d = (n + 1) / d, exact rfl,
    rw this,
    rw succ_div,
    have : n.div d = n / d, exact rfl,
    rw this,
    have : n.succ = n + 1, exact rfl,
    rw this at h,
    simp [h],
  },
end

lemma step2 :
∀ (x : ℕ),
(∑ d in finset.Icc 1 x, ((μ d) * ((finset.Icc 1 x).filter (has_dvd.dvd (d ^ 2))).card)) =
(∑ d in finset.Icc 1 x, ((μ d) * x.div (d^2)))
:=
begin
  intros x,
  apply finset.sum_congr,
  simp,
  intros y hy,
  rw num_divides_upto_eq,
end

-- Shorten the sum
lemma sqrt_magnitude {n : ℕ} : 2 ≤ n → 1 ≤ sqrt n ∧ (sqrt n + 1) ≤ n :=
begin
  intros hn,
  split,
  linarith [sqrt_pos.mpr (calc 0 < 2 : by linarith ... ≤ n : hn)],
  linarith [sqrt_lt_self (calc 1 < 2 : by linarith ... ≤ n : hn)],
end

lemma step3 :
∀ (x : ℕ),
(∑ d in finset.Icc 1 x, ((μ d) * x.div (d^2))) =
(∑ d in finset.Icc 1 (sqrt x), ((μ d) * x.div (d^2)))
:=
begin
  intros x,
  by_cases x0 : x = 0,
  rw x0,
  simp,
  by_cases x1 : x = 1,
  rw x1,
  rw sqrt_one,
  have x2 : 2 ≤ x, exact two_le_nat_iff_not_zero_one.mpr ⟨x0, x1⟩,
  have : 1 ≤ sqrt x ∧ (sqrt x + 1) ≤ x, exact sqrt_magnitude x2,
  obtain ⟨fs_union, fs_disjoint⟩ := Icc_neighbor this.left this.right,
  rw fs_union,
  rw finset.sum_union fs_disjoint,
  simp,
  apply sum_eq_zero,
  intros y hy,
  have : x.div (y ^ 2) = x / (y ^ 2), exact rfl,
  rw this,
  simp,
  right,
  rw int.div_eq_zero_of_lt,
  linarith,
  simp at hy,
  have aaa : x < ((sqrt x) + 1) ^ 2, exact nat.lt_succ_sqrt' x,
  zify at aaa,
  rcases hy with ⟨hyl, hyr⟩,
  have hyl2 : ((sqrt x) + 1) ^ 2 ≤ y ^ 2, exact nat.pow_le_pow_of_le_left hyl 2,
  zify at hyl2,
  calc ↑x < (↑(sqrt x) + 1) ^ 2 : aaa
    ... ≤ ↑y ^ 2 : hyl2,
end

-- It's a lot easier to work with Ico's than Icc's because programming
-- But this means we pick up an O(1) term. Prove this is true!
lemma Icc_eq_Ico_union_singleton {a b : ℕ} (hab : a ≤ b) :
finset.Icc a b = finset.Ico a b ∪ {b} ∧ disjoint (finset.Ico a b) {b} :=
begin
  simp,
  ext x,
  simp,
  split,
  rintros ⟨hax, hxb⟩,
  simp [hax, hxb, lt_or_eq_of_le],
  intros h,
  cases h,
  simp [h, le_of_lt],
  simp [hab, h, le_of_eq],
end

lemma quadratic_monotone_eventually
{a b c : ℝ}
(ha : 0 < a)
:
monotone_on (λ x, a * x ^ 2 + b * x + c) (set.Ici (-b / (2 * a)))
:=
begin
  -- This computation is annoyingly difficult
  have two_a_ne_zero : 2 * a ≠ 0, linarith [ha],
  have : 0 = a * 2 * (-b / (2 * a)) + b,
    ring_nf,
    have : (2 * (2 * a)⁻¹ * b * a) = ((2 * a) * (2 * a)⁻¹ * b), ring,
    rw this,
    rw mul_inv_cancel two_a_ne_zero,
    ring,

  have final_ineq : ∀ (x : ℝ), -b / (2 * a) ≤ x → 0 ≤ a * 2 * x + b,
    intros x hx,
    rw this,
    -- Why does add_lt_add_of_lt_of_le not have an equivalent with all lt's replaced by le's?
    apply add_le_add,
    rw mul_le_mul_left,
    exact hx,
    linarith [ha],
    exact rfl.le,

  let f := (polynomial.monomial 2 a) + (polynomial.monomial 1 b) + (polynomial.C c),
  have : (λ x, f.eval x) = (λ (x : ℝ), a * x ^ 2 + b * x + c),
  {
    funext,
    simp,
  },
  rw ← this,
  apply convex.monotone_on_of_deriv_nonneg (convex_Ici (-b / (2 * a))) (polynomial.continuous_on f) (polynomial.differentiable_on f),
  intros x hx,
  have aa : f.derivative = polynomial.monomial 1 (a * 2) + polynomial.C b, {
    simp,
  },
  have bb : deriv (λ (x : ℝ), f.eval x) = (λ (x : ℝ), (f.derivative.eval x)), {
    funext,
    simp,
    ring,
  },
  rw [bb, aa],
  simp,
  simp at hx,
  exact final_ineq x (le_of_lt hx),
end

lemma zero_dumb
{n : ℕ}
(hn : n ≠ 0)
(hn' : n ≤ 1)
:
n = 1 :=
begin
  have : 0 ≤ n, simp,
  have : 0 < n ∨ 0 = n, exact lt_or_eq_of_le this,
  simp [hn.symm] at this,
  have : (0 : ℕ).succ ≤ n, exact succ_le_iff.mpr this,
  linarith,
end

lemma nat_div_sqrt_sqrt_eq_one
{n : ℕ}
:
9 ≤ n → n.div (sqrt n * sqrt n) = 1
:=
begin
  -- In fact, this value for n = 8 is 3 which is the max
  intros hn,
  have one_le_sqrt_n : 1 ≤ sqrt n,  {
    rw ← sqrt_one,
    apply sqrt_le_sqrt,
    calc 1 ≤ 9 : by linarith ... ≤ n : hn,
  },

  have zero_lt_sqrt_n : 0 < sqrt n, calc 0 < 1 : by linarith ... ≤ sqrt n : one_le_sqrt_n,
  have le_half : n / (sqrt n * sqrt n) ≠ 0, {
    by_contradiction H,
    rw nat.div_eq_zero_iff at H,
    let bar := calc sqrt n * sqrt n ≤ n : nat.sqrt_le n ... < sqrt n * sqrt n : H,
    linarith,
    simp [zero_lt_sqrt_n],
  },

  have : n ≤ (sqrt n + 1) * (sqrt n + 1), exact le_of_lt (nat.lt_succ_sqrt n),
  have blah : n / (sqrt n * sqrt n) ≤ ((sqrt n + 1) * (sqrt n + 1)) / ((sqrt n) * (sqrt n)), {
    exact nat.div_le_div_right this,
  },
  have : ((sqrt n + 1) * (sqrt n + 1)) = (sqrt n * sqrt n) + 2 * sqrt n + 1, ring,
  rw this at blah,
  have zzz : 2 * sqrt n + 1 < sqrt n * sqrt n,
  {
    let f := (λ (x : ℝ), 1 * x ^ 2 + -2 * x + -1),
    have fequiv : ∀ (x : ℝ), f x = 1 * x ^ 2 + -2 * x + -1, simp,
    have : monotone_on f (set.Ici (- - 2 / (2 * 1))),
      exact quadratic_monotone_eventually (by simp),

    have aa : 3 ≤ sqrt n, {
      have : 9 = 3 * 3, dec_trivial,
      have : sqrt 9 = 3, rw this, exact sqrt_eq 3,
      calc 3 = sqrt 9 : this.symm ... ≤ sqrt n : sqrt_le_sqrt hn,
    },
    have aa' : (3 : ℝ) ≤ ↑(sqrt n), {
      have : (3 : ℝ) = ↑(3 : ℕ), simp,
      rw this,
      exact cast_le.mpr aa,
    },
    have bb : - - (2: ℝ) / (2 * 1) ≤ 3, simp,
    have bb' : (3 : ℝ) ∈ set.Ici (- - (2: ℝ) / (2 * 1)), simp [bb],
    have cc : - - (2 : ℝ) / (2 * 1) ≤ ↑(sqrt n), calc - - (2 : ℝ) / (2 * 1) ≤ (3 : ℝ) : bb ... ≤ ↑(sqrt n) : aa',
    have cc' : ↑(sqrt n) ∈ set.Ici (- - (2: ℝ) / (2 * 1)), simp, linarith,
    unfold monotone_on at this,
    specialize this bb' cc' aa',
    have aa : 0 < f 3, simp,
    linarith,
    zify,
    have bb : f ↑(sqrt n) = ↑(((sqrt n * sqrt n) : ℤ) - 2 * (sqrt n) - 1), {
      rw fequiv,
      norm_cast,
      simp,
      ring,
    },
    have : (0 : ℝ) < ↑(((sqrt n * sqrt n) : ℤ) - 2 * (sqrt n) - 1), linarith,
    norm_cast at this,
    simp at this,
    linarith,
  },
  have : (2 * sqrt n + 1) / (sqrt n * sqrt n) = 0, exact nat.div_eq_zero zzz,
  have : (sqrt n * sqrt n + 2 * sqrt n + 1) / (sqrt n * sqrt n) = (2 * sqrt n + 1) / (sqrt n * sqrt n) + 1,
    apply nat.add_div_left (2 * sqrt n + 1),
    linarith,
  rw nat.div_eq_zero zzz at this,
  rw this at blah,
  simp at blah,

  -- OK, I have that it's ≤ 1 and that it ≠ 0 so why is this so hard :'-(
    exact zero_dumb le_half blah,
end

lemma step35 :
is_Ot
(λ x, (∑ d in finset.Icc 1 (sqrt x), ((μ d) * x.div (d^2))))
(λ x, (∑ d in finset.Ico 1 (sqrt x), ((μ d) * x.div (d^2))))
1
at_top
:=
begin
  unfold is_Ot,
  use 1,
  unfold asymptotics.is_O_with,
  simp,
  use 100,
  intros n hn,
  rw real.norm_eq_abs,
  have : 1 ≤ sqrt n, {rw ← sqrt_one, apply sqrt_le_sqrt, calc 1 ≤ 100 : by linarith ... ≤ n : hn, },
  rw (Icc_eq_Ico_union_singleton this).left,
  rw finset.sum_union (Icc_eq_Ico_union_singleton this).right,
  simp,
  rw pow_two,
  have : 9 ≤ n, linarith,
  rw nat_div_sqrt_sqrt_eq_one this,
  simp,
  -- Explicit casts :-(
  conv {
    to_lhs,
    rw ← int.cast_abs,
  },
  rw ← int.cast_one,
  rw int.cast_le,
  exact abs_mu_le_one,
end

lemma first_steps :
∀ (x : ℕ),
∑ n in finset.Icc 1 x, squarefree_nat n =
(∑ d in finset.Icc 1 (sqrt x), ((μ d) * x.div (d^2)))
:=
begin
  intros x,
  transitivity, exact step0 x,
  transitivity, exact step05 x,
  transitivity, exact step1 x,
  transitivity, exact step2 x,
  transitivity, exact step3 x,
  refl,
end

/- The casts will screw us up below -/
lemma first_steps_R :
∀ (x : ℕ),
∑ n in finset.Icc 1 x, ((squarefree_nat n) : ℝ) =
(∑ d in finset.Icc 1 (sqrt x), ((μ d) * x.div (d^2)))
:=
begin
  intros x,
  norm_cast,
  exact first_steps x,
end

lemma first_steps' :
is_Ot
(λ x, (∑ n in finset.Icc 1 x, squarefree_nat n))
(λ x, (∑ d in finset.Ico 1 (sqrt x), ((μ d) * x.div (d^2))))
1
at_top
:=
begin
  conv {
    congr,
    funext,
    rw first_steps_R x,
  },
  exact step35,
end

-- Converting from natural division to real division only picks up √x in error
def μ_over_d2 (d : ℕ) := ↑(μ d) * ((d : ℝ) ^ 2)⁻¹

def sum_μ_times_floor_n_over_d2 (n : ℕ) :=
((∑ d in finset.Ico 1 (sqrt n), (μ d) * n.div (d^2)) : ℝ)

def sum_μ_times_n_over_d2 (n : ℕ) :=
∑ d in finset.Ico 1 (sqrt n), ↑n * μ_over_d2 d -- ↑(μ d) * ↑n * ((d : ℝ) ^ 2)⁻¹

lemma dumbdumb {a b c d : ℝ} : |a * b - c * (a * d)| = |a| * |b - c * d| :=
begin
  ring_nf,
  rw abs_mul,
  conv {
    to_lhs,
    congr,
    congr,
    congr,
    skip,
    rw mul_comm,
  },
end

lemma afaf {a b : ℝ} : |a| ≤ 1 ∧ |b| ≤ 1 → |a| * |b| ≤ 1 :=
begin
  rintros ⟨ha, hb⟩,
  have : (1 : ℝ) = 1 * 1, ring,
  rw this,
  exact mul_le_mul ha hb (abs_nonneg b) (by linarith),
end

lemma step4 :
is_Ot
sum_μ_times_floor_n_over_d2
sum_μ_times_n_over_d2
(λ n, ((sqrt n) : ℝ))
at_top
:=
begin
  unfold is_Ot,
  use 1,
  unfold asymptotics.is_O_with,
  simp,
  use 100,
  intros b hb,
  rw real.norm_eq_abs,
  unfold sum_μ_times_floor_n_over_d2,
  unfold sum_μ_times_n_over_d2,
  rw ← finset.sum_sub_distrib,
  transitivity,
  exact finset.abs_sum_le_sum_abs _ _,
  have u1 : ∀ (d : ℕ), b.div (d ^ 2) = b / (d ^ 2), {
    intros d,
    unfold has_div.div,
  },
  have u2 : ∀ (d : ℕ), (b : ℝ) * (↑d ^ 2)⁻¹ = (b : ℝ) / ↑(d ^ 2), {
    intros d,
    rw div_eq_mul_inv,
    simp,
  },
  unfold μ_over_d2,
  conv {
    to_lhs,
    congr,
    skip,
    funext,
    rw dumbdumb,
    rw u1 x,
    rw u2 x,
    rw abs_sub_comm,
  },
  have u3 : ∀ (d : ℕ), 0 < d → |((μ d) : ℝ)| * |(b : ℝ) / ↑(d ^ 2) - ↑(b / d ^ 2)| ≤ 1,
  {
    intros d hd,
    apply afaf,
    split,
    rw ← int.cast_abs,
    have : (1 : ℝ) = ↑(1 : ℤ), simp,
    rw this,
    rw int.cast_le,
    exact abs_mu_le_one,
    exact floor_off_by_le_one,
  },
  have u4 : ∑ (d : ℕ) in finset.Ico 1 (sqrt b), |((μ d) : ℝ)| * |(b : ℝ) / ↑(d ^ 2) - ↑(b / d ^ 2)| ≤ ∑ (d : ℕ) in finset.Ico 1 (sqrt b), 1,
  {
    apply finset.sum_le_sum,
    intros i hi,
    simp at hi,
    exact u3 i (by linarith [hi.left]),
  },
  transitivity,
  exact u4,
  simp,
end

def μ_sum_at_2 := ∑' i, μ_over_d2 i

lemma summable_μ_over_d2 : summable μ_over_d2 :=
begin
  rw ← summable_abs_iff,
  unfold μ_over_d2,
  have u1 : ∀ (i : ℕ), | ((μ i) : ℝ) * (↑i ^ 2)⁻¹| ≤ (↑i ^ 2)⁻¹,
  {
    intros i,
    rw abs_mul,
    by_cases hi : i = 0,
      simp [hi],
    have hi : 0 < i, exact zero_lt_iff.mpr hi,
    have : 0 < ((i : ℝ) ^ 2)⁻¹, simp, norm_cast, apply pow_pos, exact hi,
    rw abs_of_pos this,
    rw mul_comm,
    rw ← le_div_iff' this,
    rw div_self ((ne_of_lt this).symm),
    have : (1 : ℝ) = ↑(1 : ℕ), simp,
    rw this,
    norm_cast,
    exact abs_mu_le_one,
  },
  have u2 : ∀ (i : ℕ), 0 ≤ | ((μ i) : ℝ) * (↑i ^ 2)⁻¹|, intros i, exact abs_nonneg _,
  apply summable_of_nonneg_of_le u2 u1,
  exact one_dirichlet_summable 2 (by simp),
end

def goal_func := (λ (n : ℕ), ↑n * μ_sum_at_2)

def one_over_d2_from (d : ℕ) := (∑' i, ite (d ≤ i) ((i : ℝ) ^ 2)⁻¹ 0)

lemma blarg
{n : ℕ}
{f : ℕ → ℝ}
(hf : f 0 = 0)
:
∑' (i : ℕ), ite (i < n) (f i) 0 = ∑ i in finset.Ico 1 n, f i
:=
begin
  rw head_sum_eq',
  symmetry,
  have : finset.Ico 1 n ⊆ finset.Ico 0 n,
  {
    rw subset_iff,
    intros x,
    simp,
  },
  apply finset.sum_subset this,
  intros x hx hx',
  have : x = 0, {
    simp at hx,
    simp at hx',
    by_contradiction H,
    have : 1 ≤ x, exact nat.one_le_iff_ne_zero.mpr H,
    linarith [calc n ≤ x : hx' this ... < n : hx],
  },
  simp [hf, this],
end

lemma tsum_sub_head_eq_tail''
{n : ℕ}
{f : ℕ → ℝ}
(hf : f 0 = 0)
:
summable f → ∑' (i : ℕ), f i - ∑ (i : ℕ) in finset.Ico 1 n, f i = ∑' (i : ℕ), ite (n ≤ i) (f i) 0
:=
begin
  rw ← blarg hf,
  exact tsum_sub_head_eq_tail_lt,
end

-- Extend the sum to infinity and pick up a O(√x) term
lemma step5' :
is_Ot
sum_μ_times_n_over_d2
goal_func
(λ (n : ℕ), ↑n * one_over_d2_from (sqrt n))
at_top
:=
begin
  unfold is_Ot,
  use 1,
  unfold asymptotics.is_O_with,
  simp,
  use 100,
  intros b hb,
  rw [real.norm_eq_abs, real.norm_eq_abs],
  unfold sum_μ_times_n_over_d2,
  unfold goal_func,
  unfold one_over_d2_from,
  have : |∑ (d : ℕ) in Ico 1 (sqrt b), ↑b * μ_over_d2 d - ↑b * μ_sum_at_2| = ↑b * |∑ (d : ℕ) in Ico 1 (sqrt b), μ_over_d2 d - μ_sum_at_2|,
  {
    rw ← mul_sum,
    rw ← mul_sub,
    rw abs_mul,
    -- Casting sadness
    have : (0 : ℝ) ≤ ↑b, {
      have : (0 : ℝ) = ↑(0 : ℕ), simp,
      rw this,
      norm_cast,
      calc 0 ≤ 100 : by linarith ... ≤ b : hb,
    },
    rw abs_of_nonneg this,
  },
  rw this,
  apply mul_le_mul,
  simp,
  {
    -- The meat of the problem
    rw abs_sub_comm,
    unfold μ_sum_at_2,
    have u1 : μ_over_d2 0 = 0, unfold μ_over_d2, simp,
    conv {
      to_lhs,
      congr,
      rw tsum_sub_head_eq_tail'' u1 summable_μ_over_d2,
    },
    transitivity,
    exact abs_tsum_le_tsum_abs,
    have u4 : ∀ (i : ℕ), 0 ≤ ite (sqrt b ≤ i) ((i : ℝ) ^ 2)⁻¹ 0, {
      intros i,
      by_cases h : sqrt b ≤ i, {
        simp [h],
      },
      {
        simp [h],
      }
    },
    rw abs_of_nonneg (tsum_nonneg u4),
    apply tsum_le_tsum,
    intros c,
    by_cases h : sqrt b ≤ c, {
      simp [h],
      unfold μ_over_d2,
      rw abs_mul,
      have : 0 < ((c : ℝ) ^ 2)⁻¹, simp, norm_cast, apply pow_pos, calc 0 < 1 : by linarith ... = sqrt 1 : sqrt_one.symm ... ≤ sqrt b : sqrt_le_sqrt (calc 1 ≤ 100 : by linarith ... ≤ b : hb) ... ≤ c : h,
      rw abs_of_pos this,
      rw mul_comm,
      rw ← le_div_iff' this,
      rw div_self ((ne_of_lt this).symm),
      have : (1 : ℝ) = ↑(1 : ℕ), simp,
      rw this,
      norm_cast,
      exact abs_mu_le_one,
    },
    {
      simp [h],
    },
    have : ∀ (c : ℕ), |ite (sqrt b ≤ c) (μ_over_d2 c) 0| = ite (sqrt b ≤ c) (|μ_over_d2 c|) 0, {
      intros c,
      by_cases h : sqrt b ≤ c,
        simp [h],
        simp [h],
    },
    conv {
      congr,
      funext,
      rw this b,
    },
    apply tail_summable',
    rw summable_abs_iff,
    exact summable_μ_over_d2,
    apply tail_summable',
    exact one_dirichlet_summable 2 (by simp),
  },
  exact abs_nonneg _,
  -- This collection of explicit casts is very annoying
  have : (0 : ℝ) = ↑ (0 : ℕ), simp,
  rw this,
  rw nat.cast_le,
  linarith [hb],
end

lemma step6 :
asymptotics.is_O
(λ (n : ℕ), ↑n * one_over_d2_from (sqrt n))
(λ (n : ℕ), (n : ℝ) ^ ((1 : ℝ) / 2))
at_top
:=
begin
  unfold asymptotics.is_O,
  use 2,
  unfold asymptotics.is_O_with,
  simp,
  use 200,
  intros b hb,
  rw [real.norm_eq_abs, real.norm_eq_abs],
  rw ← le_div_iff' (calc (0 : ℝ) < ↑(200 : ℕ) : by {simp, linarith, } ... ≤ ↑b : cast_le.mpr hb),
  unfold one_over_d2_from,
  transitivity,
  exact abs_tsum_le_tsum_abs,

  have : ∑' (i : ℕ), |ite (sqrt b ≤ i) ((i : ℝ) ^ 2)⁻¹ 0| = ∑' (i : ℕ), ite (sqrt b ≤ i) ((i : ℝ) ^ 2)⁻¹ 0,
    congr, funext, simp, by_cases sqrt b ≤ i, simp [h], simp [h],
  rw this,

  obtain ⟨c, hc, hc_zero⟩ : ∃ (c : ℕ), sqrt b = c + 1 ∧ 0 < c, exact asdfasdf hb,
  rw hc,
  have hc_cast' : (0 : ℝ) < ↑c, simp [hc_zero],
  have hc_cast : (0 : ℝ) ≤ ↑c, exact le_of_lt hc_cast',
  have : - ↑c ^ (-(2 : ℝ) + 1) / (-(2 : ℝ) + 1) ≤ 2 * |(b : ℝ) ^ (2 : ℝ)⁻¹| / ↑b, exact extraordinarily_annoying hb hc,
  rw ← ge_iff_le,
  transitivity,
  exact this,
  rw ge_iff_le,
  refine @tail_sum_le_tail_integral _ _ (λ (x : ℝ), (x ^ 2)⁻¹) _ _ _,
  have : (λ (b : ℕ), ∫ (x : ℝ) in ↑c..↑b, (λ (x : ℝ), (x ^ 2)⁻¹) x) = (λ (b : ℕ), (λ (b' : ℝ), ∫ (x : ℝ) in ↑c..b', (λ (x : ℝ), (x ^ (-2 : ℝ))) x) ↑b), {
    funext d,
    simp,
    apply interval_integral.integral_congr,
    unfold set.eq_on,
    intros x hx,
    rw real.rpow_neg,
    norm_cast,
    by_cases h : c ≤ d,
      rw interval_eq_Icc (cast_le.mpr h) at hx,
      simp at hx,
      calc (0 : ℝ) = ↑(0 : ℕ) : by simp ... ≤ ↑c : cast_le.mpr (zero_le c) ... ≤ x : hx.left,

      push_neg at h,
      rw interval_eq_Icc' (cast_le.mpr (le_of_lt h)) at hx,
      simp at hx,
      calc (0 : ℝ) = ↑(0 : ℕ) : by simp ... ≤ ↑d : cast_le.mpr (zero_le d) ... ≤ x : hx.left,
  },
  rw this,
  refine tendsto.comp _ tendsto_coe_nat_at_top_at_top,
  exact integral_rpow_tendsto_at_top ↑c (-2) hc_cast' (by linarith),
  {
    unfold antitone_on,
    intros a ha b hb hab,

    have b_cast: (b ^ (2 : ℕ)) = (b ^ (2 : ℝ)), norm_cast,
    rw b_cast,
    have a_cast: (a ^ (2 : ℕ)) = (a ^ (2 : ℝ)), norm_cast,
    rw a_cast,
    rw inv_le_inv,
    apply real.rpow_le_rpow,
    simp at ha,
    calc (0 : ℝ) ≤ ↑c : hc_cast ... ≤ a : ha,
    exact hab,
    linarith,

    rw ← b_cast,
    apply pow_pos,
    simp at hb,
    calc (0 : ℝ) < ↑c : hc_cast' ... ≤ b : hb,

    rw ← a_cast,
    apply pow_pos,
    simp at ha,
    calc (0 : ℝ) < ↑c : hc_cast' ... ≤ a : ha,
  },
  {
    intros a ha,
    simp,
    apply pow_nonneg,
    simp at ha,
    calc (0 : ℝ) ≤ ↑c : hc_cast ... ≤ a : ha,
  },
end

lemma step45 :
asymptotics.is_O
(λ (n : ℕ), ((sqrt n) : ℝ))
(λ (n : ℕ), (n : ℝ) ^ ((1 : ℝ) / 2))
at_top
:=
begin
  unfold asymptotics.is_O,
  use 1,
  unfold asymptotics.is_O_with,
  simp,
  use 1,
  intros b hb,
  rw real.norm_eq_abs,
  rw mul_self_le_mul_self_iff _ _,
  rw ← abs_mul,
  simp,
  rw ← real.rpow_add,
  have : (2 : ℝ)⁻¹ + 2⁻¹ = 1, ring,
  rw this,
  simp,
  norm_cast,
  exact sqrt_le b,
  norm_cast,
  linarith,
  norm_cast,
  simp,
  exact abs_nonneg _,
end

/- Putting all the steps together -/
theorem bigbad :
is_Ot
(λ (n : ℕ), ∑ (i : ℕ) in finset.Icc 1 n, squarefree_nat i)
goal_func
(λ (n : ℕ), (n : ℝ) ^ ((1 : ℝ) / 2))
at_top
:=
begin
  refine is_Ot_trans_bigger_error_right _ step5' step6,
  refine is_Ot_bigger_error _ step45,
  refine is_Ot_trans_same_error _ step4,
  refine is_Ot_trans_bigger_error_right _ first_steps' _,
  apply is_Ot.congr,
  simp,
  unfold asymptotics.is_O,
  use 1,
  unfold asymptotics.is_O_with,
  rw eventually_iff,
  simp,
  use 1,
  intros b hb,
  rw ←sqrt_one,
  exact sqrt_le_sqrt hb,
end

end squarefree_sums


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.pfunctor.multivariate.basic
import Mathlib.PostPort

universes u l u_1 u_2

namespace Mathlib

/-!
# The W construction as a multivariate polynomial functor.

W types are well-founded tree-like structures. They are defined
as the least fixpoint of a polynomial functor.

## Main definitions

 * `W_mk`     - constructor
 * `W_dest    - destructor
 * `W_rec`    - recursor: basis for defining functions by structural recursion on `P.W α`
 * `W_rec_eq` - defining equation for `W_rec`
 * `W_ind`    - induction principle for `P.W α`

## Implementation notes

Three views of M-types:

 * `Wp`: polynomial functor
 * `W`: data type inductively defined by a triple: shape of the root, data in the root and children of the root
 * `W`: least fixed point of a polynomial functor

Specifically, we define the polynomial functor `Wp` as:

 * A := a tree-like structure without information in the nodes
 * B := given the tree-like structure `t`, `B t` is a valid path
   (specified inductively by `W_path`) from the root of `t` to any given node.

As a result `Wp.obj α` is made of a dataless tree and a function from
its valid paths to values of `α`

## Reference

 * [Jeremy Avigad, Mario M. Carneiro and Simon Hudon, *Data Types as Quotients of Polynomial Functors*][avigad-carneiro-hudon2019]
-/

namespace mvpfunctor

/-- A path from the root of a tree to one of its node -/
inductive W_path {n : ℕ} (P : mvpfunctor (n + 1)) : pfunctor.W (last P) → fin2 n → Type u where
| root :
    (a : A P) →
      (f : pfunctor.B (last P) a → pfunctor.W (last P)) →
        (i : fin2 n) → B (drop P) a i → W_path P (W_type.mk a f) i
| child :
    (a : A P) →
      (f : pfunctor.B (last P) a → pfunctor.W (last P)) →
        (i : fin2 n) → (j : pfunctor.B (last P) a) → W_path P (f j) i → W_path P (W_type.mk a f) i

protected instance W_path.inhabited {n : ℕ} (P : mvpfunctor (n + 1)) (x : pfunctor.W (last P))
    {i : fin2 n} [I : Inhabited (B (drop P) (pfunctor.W.head x) i)] : Inhabited (W_path P x i) :=
  { default := sorry }

/-- Specialized destructor on `W_path` -/
def W_path_cases_on {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {a : A P}
    {f : pfunctor.B (last P) a → pfunctor.W (last P)} (g' : typevec.arrow (B (drop P) a) α)
    (g : (j : pfunctor.B (last P) a) → typevec.arrow (W_path P (f j)) α) :
    typevec.arrow (W_path P (W_type.mk a f)) α :=
  sorry

/-- Specialized destructor on `W_path` -/
def W_path_dest_left {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {a : A P}
    {f : pfunctor.B (last P) a → pfunctor.W (last P)}
    (h : typevec.arrow (W_path P (W_type.mk a f)) α) : typevec.arrow (B (drop P) a) α :=
  fun (i : fin2 n) (c : B (drop P) a i) => h i (W_path.root a f i c)

/-- Specialized destructor on `W_path` -/
def W_path_dest_right {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {a : A P}
    {f : pfunctor.B (last P) a → pfunctor.W (last P)}
    (h : typevec.arrow (W_path P (W_type.mk a f)) α) (j : pfunctor.B (last P) a) :
    typevec.arrow (W_path P (f j)) α :=
  fun (i : fin2 n) (c : W_path P (f j) i) => h i (W_path.child a f i j c)

theorem W_path_dest_left_W_path_cases_on {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {a : A P}
    {f : pfunctor.B (last P) a → pfunctor.W (last P)} (g' : typevec.arrow (B (drop P) a) α)
    (g : (j : pfunctor.B (last P) a) → typevec.arrow (W_path P (f j)) α) :
    W_path_dest_left P (W_path_cases_on P g' g) = g' :=
  rfl

theorem W_path_dest_right_W_path_cases_on {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {a : A P}
    {f : pfunctor.B (last P) a → pfunctor.W (last P)} (g' : typevec.arrow (B (drop P) a) α)
    (g : (j : pfunctor.B (last P) a) → typevec.arrow (W_path P (f j)) α) :
    W_path_dest_right P (W_path_cases_on P g' g) = g :=
  rfl

theorem W_path_cases_on_eta {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {a : A P}
    {f : pfunctor.B (last P) a → pfunctor.W (last P)}
    (h : typevec.arrow (W_path P (W_type.mk a f)) α) :
    W_path_cases_on P (W_path_dest_left P h) (W_path_dest_right P h) = h :=
  sorry

theorem comp_W_path_cases_on {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : typevec n}
    (h : typevec.arrow α β) {a : A P} {f : pfunctor.B (last P) a → pfunctor.W (last P)}
    (g' : typevec.arrow (B (drop P) a) α)
    (g : (j : pfunctor.B (last P) a) → typevec.arrow (W_path P (f j)) α) :
    typevec.comp h (W_path_cases_on P g' g) =
        W_path_cases_on P (typevec.comp h g')
          fun (i : pfunctor.B (last P) a) => typevec.comp h (g i) :=
  sorry

/-- Polynomial functor for the W-type of `P`. `A` is a data-less well-founded
tree whereas, for a given `a : A`, `B a` is a valid path in tree `a` so
that `Wp.obj α` is made of a tree and a function from its valid paths to
the values it contains  -/
def Wp {n : ℕ} (P : mvpfunctor (n + 1)) : mvpfunctor n := mk (pfunctor.W (last P)) (W_path P)

/-- W-type of `P` -/
def W {n : ℕ} (P : mvpfunctor (n + 1)) (α : typevec n) := obj (Wp P) α

protected instance mvfunctor_W {n : ℕ} (P : mvpfunctor (n + 1)) : mvfunctor (W P) :=
  id (obj.mvfunctor (Wp P))

/-!
First, describe operations on `W` as a polynomial functor.
-/

/-- Constructor for `Wp` -/
def Wp_mk {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (a : A P)
    (f : pfunctor.B (last P) a → pfunctor.W (last P))
    (f' : typevec.arrow (W_path P (W_type.mk a f)) α) : W P α :=
  sigma.mk (W_type.mk a f) f'

/-- Recursor for `Wp` -/
def Wp_rec {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {C : Type u_2}
    (g :
      (a : A P) →
        (f : pfunctor.B (last P) a → pfunctor.W (last P)) →
          typevec.arrow (W_path P (W_type.mk a f)) α → (pfunctor.B (last P) a → C) → C)
    (x : pfunctor.W (last P)) (f' : typevec.arrow (W_path P x) α) : C :=
  sorry

theorem Wp_rec_eq {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {C : Type u_2}
    (g :
      (a : A P) →
        (f : pfunctor.B (last P) a → pfunctor.W (last P)) →
          typevec.arrow (W_path P (W_type.mk a f)) α → (pfunctor.B (last P) a → C) → C)
    (a : A P) (f : pfunctor.B (last P) a → pfunctor.W (last P))
    (f' : typevec.arrow (W_path P (W_type.mk a f)) α) :
    Wp_rec P g (W_type.mk a f) f' =
        g a f f' fun (i : pfunctor.B (last P) a) => Wp_rec P g (f i) (W_path_dest_right P f' i) :=
  rfl

-- Note: we could replace Prop by Type* and obtain a dependent recursor

theorem Wp_ind {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n}
    {C : (x : pfunctor.W (last P)) → typevec.arrow (W_path P x) α → Prop}
    (ih :
      ∀ (a : A P) (f : pfunctor.B (last P) a → pfunctor.W (last P))
        (f' : typevec.arrow (W_path P (W_type.mk a f)) α),
        (∀ (i : pfunctor.B (last P) a), C (f i) (W_path_dest_right P f' i)) → C (W_type.mk a f) f')
    (x : pfunctor.W (last P)) (f' : typevec.arrow (W_path P x) α) : C x f' :=
  sorry

/-!
Now think of W as defined inductively by the data ⟨a, f', f⟩ where
- `a  : P.A` is the shape of the top node
- `f' : P.drop.B a ⟹ α` is the contents of the top node
- `f  : P.last.B a → P.last.W` are the subtrees
 -/

/-- Constructor for `W` -/
def W_mk {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (a : A P)
    (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → W P α) : W P α :=
  let g : pfunctor.B (last P) a → pfunctor.W (last P) :=
    fun (i : pfunctor.B (last P) a) => sigma.fst (f i);
  let g' : typevec.arrow (W_path P (W_type.mk a g)) α :=
    W_path_cases_on P f' fun (i : pfunctor.B (last P) a) => sigma.snd (f i);
  sigma.mk (W_type.mk a g) g'

/-- Recursor for `W` -/
def W_rec {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {C : Type u_1}
    (g :
      (a : A P) →
        typevec.arrow (B (drop P) a) α →
          (pfunctor.B (last P) a → W P α) → (pfunctor.B (last P) a → C) → C) :
    W P α → C :=
  sorry

/-- Defining equation for the recursor of `W` -/
theorem W_rec_eq {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {C : Type u_1}
    (g :
      (a : A P) →
        typevec.arrow (B (drop P) a) α →
          (pfunctor.B (last P) a → W P α) → (pfunctor.B (last P) a → C) → C)
    (a : A P) (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → W P α) :
    W_rec P g (W_mk P a f' f) = g a f' f fun (i : pfunctor.B (last P) a) => W_rec P g (f i) :=
  sorry

/-- Induction principle for `W` -/
theorem W_ind {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {C : W P α → Prop}
    (ih :
      ∀ (a : A P) (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → W P α),
        (∀ (i : pfunctor.B (last P) a), C (f i)) → C (W_mk P a f' f))
    (x : W P α) : C x :=
  sorry

theorem W_cases {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {C : W P α → Prop}
    (ih :
      ∀ (a : A P) (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → W P α),
        C (W_mk P a f' f))
    (x : W P α) : C x :=
  W_ind P
    fun (a : A P) (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → W P α)
      (ih' : ∀ (i : pfunctor.B (last P) a), C (f i)) => ih a f' f

/-- W-types are functorial -/
def W_map {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : typevec n} (g : typevec.arrow α β) :
    W P α → W P β :=
  fun (x : W P α) => mvfunctor.map g x

theorem W_mk_eq {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (a : A P)
    (f : pfunctor.B (last P) a → pfunctor.W (last P)) (g' : typevec.arrow (B (drop P) a) α)
    (g : (j : pfunctor.B (last P) a) → typevec.arrow (W_path P (f j)) α) :
    (W_mk P a g' fun (i : pfunctor.B (last P) a) => sigma.mk (f i) (g i)) =
        sigma.mk (W_type.mk a f) (W_path_cases_on P g' g) :=
  rfl

theorem W_map_W_mk {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : typevec n}
    (g : typevec.arrow α β) (a : A P) (f' : typevec.arrow (B (drop P) a) α)
    (f : pfunctor.B (last P) a → W P α) :
    mvfunctor.map g (W_mk P a f' f) =
        W_mk P a (typevec.comp g f') fun (i : pfunctor.B (last P) a) => mvfunctor.map g (f i) :=
  sorry

-- TODO: this technical theorem is used in one place in constructing the initial algebra.

-- Can it be avoided?

/-- Constructor of a value of `P.obj (α ::: β)` from components.
Useful to avoid complicated type annotation -/
def obj_append1 {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {β : Type u} (a : A P)
    (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → β) : obj P (α ::: β) :=
  sigma.mk a (typevec.split_fun f' f)

theorem map_obj_append1 {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} {γ : typevec n}
    (g : typevec.arrow α γ) (a : A P) (f' : typevec.arrow (B (drop P) a) α)
    (f : pfunctor.B (last P) a → W P α) :
    mvfunctor.map (g ::: W_map P g) (obj_append1 P a f' f) =
        obj_append1 P a (typevec.comp g f') fun (x : pfunctor.B (last P) a) => W_map P g (f x) :=
  sorry

/-!
Yet another view of the W type: as a fixed point for a multivariate polynomial functor.
These are needed to use the W-construction to construct a fixed point of a qpf, since
the qpf axioms are expressed in terms of `map` on `P`.
-/

/-- Constructor for the W-type of `P` -/
def W_mk' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} : obj P (α ::: W P α) → W P α := sorry

/-- Destructor for the W-type of `P` -/
def W_dest' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} : W P α → obj P (α ::: W P α) :=
  W_rec P
    fun (a : A P) (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → W P α)
      (_x : pfunctor.B (last P) a → obj P (α ::: W P α)) => sigma.mk a (typevec.split_fun f' f)

theorem W_dest'_W_mk {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (a : A P)
    (f' : typevec.arrow (B (drop P) a) α) (f : pfunctor.B (last P) a → W P α) :
    W_dest' P (W_mk P a f' f) = sigma.mk a (typevec.split_fun f' f) :=
  sorry

theorem W_dest'_W_mk' {n : ℕ} (P : mvpfunctor (n + 1)) {α : typevec n} (x : obj P (α ::: W P α)) :
    W_dest' P (W_mk' P x) = x :=
  sorry

end Mathlib


variable {α : Type*}

def is_prefix (l₁ : list α) (l₂ : list α) : Prop :=
  ∃ t, l₁ ++ t = l₂

infix ` <+: `:50 := is_prefix

attribute [simp]
theorem list.is_prefix_refl (l : list α) : l <+: l :=
  ⟨[], by simp⟩

example : [1, 2, 3] <+: [1, 2, 3] := by simp


/-
Copyright (c) 2023 Wojciech Nawrocki. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Wojciech Nawrocki
-/

import Mathlib.Tactic.Linarith

import ProofChecker.Data.HashMap.Lemmas
import ProofChecker.Data.HashSet
import ProofChecker.Model.ToMathlib
import ProofChecker.Model.PropTerm
import ProofChecker.Model.PropVars

abbrev Var := PNat

namespace Var

instance : ToString Var where
  toString x := toString x.val

instance : Hashable Var where
  hash v := hash v.val

instance : Ord Var where
  compare a b := compare a.val b.val

end Var

/-! Literals -/

def ILit := { i : Int // i ≠ 0 }
  deriving DecidableEq, Repr

namespace ILit

def mkPos (x : Var) : ILit :=
  ⟨Int.ofNat x.val, by simp⟩

def mkNeg (x : Var) : ILit :=
  ⟨-Int.ofNat x.val, by simp⟩

def mk (x : Var) (p : Bool) : ILit :=
  if p then mkPos x else mkNeg x

instance : Coe Var ILit :=
  ⟨mkPos⟩

def var (l : ILit) : Var :=
  ⟨Int.natAbs l.val, Int.natAbs_pos.mpr l.property⟩

def polarity (l : ILit) : Bool :=
  (0 : Int) < l.val

def negate (l : ILit) : ILit :=
  ⟨-l.val, Int.neg_ne_zero.mpr l.property⟩

instance : Neg ILit := ⟨negate⟩

instance : ToString ILit where
  toString l := if l.polarity then s!"{l.var}" else s!"-{l.var}"

/-! Theorems about `ILit` -/

@[simp]
theorem var_mkPos (x :  Var) : var (mkPos x) = x :=
  Subtype.ext (Int.natAbs_ofNat x.val)

@[simp]
theorem var_mkNeg (x : Var) : var (mkNeg x) = x := by
  apply Subtype.ext
  simp [var, mkNeg]
  rfl

@[simp]
theorem var_mk (x : Var) (p : Bool) : var (mk x p) = x := by
  dsimp [mk]; split <;> simp

@[simp]
theorem polarity_mkPos (x : Var) : polarity (mkPos x) = true := by
  simp [polarity, mkPos]

@[simp]
theorem polarity_mkNeg (x : Var) : polarity (mkNeg x) = false := by
  simp [polarity, mkNeg]

@[simp]
theorem polarity_mk (x : Var) (p : Bool) : polarity (mk x p) = p := by
  dsimp [mk]; split <;> simp_all

@[simp]
theorem var_negate (l : ILit) : (-l).var = l.var := by
  simp only [var, Neg.neg, negate]
  apply Subtype.ext
  apply Int.natAbs_neg

theorem polarity_eq {l₁ l₂ : ILit} :
    l₁.polarity = l₂.polarity ↔ ((0 : Int) < l₁.val ↔ (0 : Int) < l₂.val) := by
  simp [polarity]

@[simp]
theorem polarity_negate (l : ILit) : (-l).polarity = !l.polarity := by
  rw [Bool.eq_bnot_to_not_eq, polarity_eq]
  intro hEq
  exact l.property (Int.eq_zero_of_lt_neg_iff_lt _ hEq)

@[ext]
theorem ext {l₁ l₂ : ILit} : l₁.var = l₂.var → l₁.polarity = l₂.polarity → l₁ = l₂ := by
  /- Strip type alias. -/
  suffices ∀ {l₁ l₂ : Int}, l₁.natAbs = l₂.natAbs → (0 < l₁ ↔ 0 < l₂) → l₁ = l₂ by
    intro h₁ h₂
    apply Subtype.ext
    apply this
    . exact Subtype.mk_eq_mk.mp h₁
    . exact polarity_eq.mp h₂
  intro l₁ l₂ h₁ h₂
  cases Int.natAbs_eq_natAbs_iff.mp h₁
  . assumption
  next h =>
    rw [h] at h₂
    have : l₂ = 0 := Int.eq_zero_of_lt_neg_iff_lt l₂ h₂
    simp [this, h]

@[simp]
theorem eta (l : ILit) : mk l.var l.polarity = l := by
  apply ext <;> simp

@[simp]
theorem eta_neg (l : ILit) : mk l.var (!l.polarity) = -l := by
  apply ext <;> simp

theorem mkPos_or_mkNeg (l : ILit) : l = .mkPos l.var ∨ l = .mkNeg l.var := by
  rw [← eta l]
  cases l.polarity
  . apply Or.inr
    simp [mk]
  . apply Or.inl
    simp [mk]

def toPropForm (l : ILit) : PropForm Var :=
  if l.polarity then .var l.var else .neg (.var l.var)

@[simp]
theorem toPropForm_mkPos (x : Var) : (mkPos x).toPropForm = .var x := by
  simp [toPropForm]

@[simp]
theorem toPropForm_mkNeg (x : Var) : (mkNeg x).toPropForm = .neg (.var x) := by
  simp [toPropForm]

def toPropTerm (l : ILit) : PropTerm Var :=
  if l.polarity then .var l.var else (.var l.var)ᶜ

@[simp]
theorem mk_toPropForm (l : ILit) : ⟦l.toPropForm⟧ = l.toPropTerm := by
  dsimp [toPropForm, toPropTerm]
  cases l.polarity <;> simp

@[simp]
theorem vars_toPropForm (l : ILit) : l.toPropForm.vars = {l.var} := by
  dsimp [toPropForm]
  cases l.polarity <;> simp [PropForm.vars]

@[simp]
theorem toPropTerm_mkPos (x : Var) : (mkPos x).toPropTerm = .var x := by
  simp [toPropTerm]

@[simp]
theorem toPropTerm_mkNeg (x : Var) : (mkNeg x).toPropTerm = (.var x)ᶜ := by
  simp [toPropTerm]

@[simp]
theorem toPropTerm_neg (l : ILit) : (-l).toPropTerm = l.toPropTermᶜ := by
  dsimp [toPropTerm]
  aesop

@[simp]
theorem semVars_toPropTerm (l : ILit) : l.toPropTerm.semVars = {l.var} := by
  dsimp [toPropTerm]
  cases l.polarity <;> simp

open PropTerm

theorem satisfies_iff {τ : PropAssignment Var} {l : ILit} :
    τ ⊨ l.toPropTerm ↔ τ l.var = l.polarity := by
  dsimp [toPropTerm, var, polarity]
  aesop

theorem satisfies_neg {τ : PropAssignment Var} {l : ILit} :
    τ ⊨ (-l).toPropTerm ↔ τ ⊭ l.toPropTerm := by
  simp [satisfies_iff]

theorem satisfies_set [DecidableEq ν] (τ : PropAssignment Var) (l : ILit) :
    τ.set l.var l.polarity ⊨ l.toPropTerm := by
  simp [satisfies_iff, τ.set_get]

theorem eq_of_flip {τ : PropAssignment Var} {l : ILit} {x : Var} {p : Bool} :
    τ ⊭ l.toPropTerm → τ.set x p ⊨ l.toPropTerm → l = mk x p := by
  simp only [satisfies_iff]
  intro h hSet
  by_cases hEq : x = var l
  . rw [hEq, τ.set_get] at hSet
    simp [hSet, hEq]
  . exfalso; exact h (τ.set_get_of_ne p hEq ▸ hSet)

theorem eq_of_flip' {τ : PropAssignment Var} {l : ILit} {x : Var} {p : Bool} :
    τ ⊨ l.toPropTerm → τ.set x p ⊭ l.toPropTerm → l = mk x !p := by
  simp only [satisfies_iff]
  intro h hSet
  by_cases hEq : x = var l
  . rw [hEq, τ.set_get] at hSet
    have : (!p) = l.polarity := by
      simp [hSet]
    simp [hEq, this]
  . exfalso; exact hSet (τ.set_get_of_ne p hEq ▸ h)

end ILit

/-! Clauses -/

abbrev IClause := Array ILit

namespace IClause

def vars (C : IClause) : HashSet Var :=
  C.foldr (init := .empty Var) fun l acc => acc.insert l.var

instance : BEq IClause :=
  inferInstanceAs (BEq IClause)

instance : ToString IClause where
  toString C := s!"({String.intercalate " ∨ " (C.map toString).toList})"

/-! Theorems about `IClause` -/

theorem mem_vars (C : IClause) (x : Var) : x ∈ C.vars.toFinset ↔ ∃ l ∈ C.data, x = l.var := by
  rw [vars, Array.foldr_eq_foldr_data]
  induction C.data <;> aesop

def toPropForm (C : IClause) : PropForm Var :=
  C.data.foldr (init := .fls) (fun l φ => l.toPropForm.disj φ)

def toPropTerm (C : IClause) : PropTerm Var :=
  C.data.foldr (init := ⊥) (fun l φ => l.toPropTerm ⊔ φ)

@[simp]
theorem mk_toPropForm (C : IClause) : ⟦C.toPropForm⟧ = C.toPropTerm := by
  dsimp [toPropForm, toPropTerm]
  induction C.data <;> simp_all

@[simp]
theorem vars_toPropForm (C : IClause) : C.toPropForm.vars = C.vars.toFinset := by
  ext x
  simp [mem_vars, toPropForm]
  induction C.data <;> simp_all [PropForm.vars]

open PropTerm

theorem satisfies_iff {τ : PropAssignment Var} {C : IClause} :
    τ ⊨ C.toPropTerm ↔ ∃ l ∈ C.data, τ ⊨ l.toPropTerm := by
  rw [toPropTerm]
  induction C.data <;> simp_all

theorem semVars_sub (C : IClause) : C.toPropTerm.semVars ⊆ C.vars.toFinset := by
  rw [← vars_toPropForm, ← mk_toPropForm]
  apply PropForm.semVars_subset_vars

theorem tautology_iff (C : IClause) :
    C.toPropTerm = ⊤ ↔ ∃ l₁ ∈ C.data, ∃ l₂ ∈ C.data, l₁ = -l₂ := by
  refine ⟨?mp, ?mpr⟩
  case mp =>
    refine not_imp_not.mp ?_
    simp only [not_exists, not_and]
    unfold toPropTerm -- :( have to do it because no induction principle for arrays
    induction C.data with
    | nil => simp
    | cons l₀ ls ih =>
      -- crazy list-array induction boilerplate
      have : ls.foldr (init := ⊥) (fun l φ => l.toPropTerm ⊔ φ) = toPropTerm ls.toArray := by
        simp [toPropTerm]
      simp only [List.foldr_cons, this] at *
      -- end boilerplate
      intro hCompl hEq
      specialize ih fun l₁ h₁ l₂ h₂ => hCompl l₁ (by simp [h₁]) l₂ (by simp [h₂])
      simp only [PropTerm.eq_top_iff, satisfies_disj, not_forall] at hEq ih
      have ⟨τ₀, h₀⟩ := ih
      have := hEq τ₀
      have : τ₀ ⊨ l₀.toPropTerm := by tauto
      let τ₁ := τ₀.set l₀.var !l₀.polarity
      have : τ₁ ⊭ l₀.toPropTerm := by simp [ILit.satisfies_iff]
      have : τ₁ ⊭ toPropTerm ls.toArray := fun h => by
        have ⟨lₛ, hₛ, hτ⟩ := satisfies_iff.mp h
        simp only [satisfies_iff, not_exists, not_and] at h₀
        have : τ₀ ⊭ lₛ.toPropTerm := h₀ lₛ hₛ
        have : lₛ = ILit.mk l₀.var !l₀.polarity := ILit.eq_of_flip this hτ
        have : lₛ = -l₀ := by simp [this]
        simp at hₛ
        apply hCompl lₛ (List.mem_cons_of_mem _ hₛ) l₀ (List.mem_cons_self _ _) this
      have := hEq τ₁
      tauto
  case mpr =>
    intro ⟨l₁, h₁, l₂, h₂, hEq⟩
    ext τ
    rw [satisfies_iff]
    by_cases hτ : τ ⊨ l₂.toPropTerm
    . aesop
    . have : τ ⊨ l₁.toPropTerm := by
        rw [hEq, ILit.satisfies_neg]
        assumption
      tauto

/-! Tautology decision procedure -/

/-- `encodes enc C` says that the hashmap `enc` encodes the (non-tautological) clause `C`.
More generally, `encodes enc C i` says that `enc` encodes the disjunction of all but the
first `i` literals of `C`. -/
def encodes (enc : HashMap Var Bool) (C : IClause) (start : Nat := 0) : Prop :=
  (∀ j : Fin C.size, start ≤ j → enc.find? C[j].var = .some C[j].polarity) ∧
    ∀ x : Var, enc.contains x ↔ ∃ j : Fin C.size, start ≤ j ∧ C[j].var = x

theorem encodes_empty (C : IClause) : encodes HashMap.empty C (Array.size C) := by
  simp [encodes]; intro j; exact not_le_of_lt j.isLt

theorem not_tautology_of_encodes (C : IClause) (enc : HashMap Var Bool) (h : encodes enc C) :
    ¬ (toPropTerm C = ⊤) := by
  rw [tautology_iff]; simp only [not_exists, not_and]
  intros l₁ hl₁ l₂ hl₂ heq
  have ⟨i, hi⟩ := C.get_of_mem_data hl₁
  have ⟨j, hj⟩ := C.get_of_mem_data hl₂
  simp only [encodes, zero_le, forall_true_left, true_and] at h
  have hi' := h.1 i
  rw [hi, heq, ILit.var_negate, ILit.polarity_negate] at hi'
  have hj' := h.1 j
  rw [hj, hi'] at hj'
  simp at hj'

theorem encodes_insert_of_find?_eq_none {C : IClause} {i : Nat} {enc : HashMap Var Bool}
      (ilt: i < C.size)
      (henc : encodes enc C (i + 1))
      (h: HashMap.find? enc C[i].var = none) :
    encodes (HashMap.insert enc C[i].var C[i].polarity) C i := by
  constructor
  . intro j hile
    cases lt_or_eq_of_le hile
    case inl h' =>
      have := henc.1 _ (Nat.succ_le_of_lt h')
      rw [HashMap.find?_insert_of_ne, this]
      rw [bne_iff_ne, ne_eq]
      intro hc
      rw [←hc, h] at this; contradiction
    case inr h' =>
      cases h'
      simp [HashMap.find?_insert]
  . intro x
    rw [HashMap.contains_insert, henc.2 x, beq_iff_eq]; simp only [getElem_fin]
    constructor
    . rintro (⟨j, hile, rfl⟩ | rfl)
      . use j, (Nat.le_succ i).trans hile
      . use ⟨i, ilt⟩; simp
    . rintro ⟨j, hile, rfl⟩
      cases lt_or_eq_of_le hile
      case inl h' =>
        left; use j, Nat.succ_le_of_lt h'
      case inr h' =>
        right; simp [h']

theorem tautology_of_encodes_of_find?_eq_some
      {C : IClause} {i : Nat} {enc : HashMap Var Bool} {p : Bool}
      (ilt: i < C.size)
      (henc : encodes enc C (i + 1))
      (h : HashMap.find? enc C[i].var = some p)
      (hpne : p ≠ C[i].polarity) :
    toPropTerm C = ⊤ := by
  rw [tautology_iff]
  use C[i], C.get_mem_data ⟨i, ilt⟩
  have : enc.contains C[i].var := by
    rw [HashMap.contains_iff]; use p; exact h
  rw [henc.2] at this
  rcases this with ⟨j, hj, h'⟩
  use C[j], C.get_mem_data j
  ext; rw [ILit.var_negate, h']
  have := henc.1 j hj
  rw [h', h, Option.some.injEq] at this
  rw [ILit.polarity_negate, Bool.eq_bnot_to_not_eq, ←this]
  exact hpne.symm

theorem encode_of_encodes_of_find?_eq_some
      {C : IClause} {i : Nat} {enc : HashMap Var Bool} {p : Bool}
      (ilt: i < C.size)
      (henc : encodes enc C (i + 1))
      (h : HashMap.find? enc C[i].var = some p)
      (hpeq : p = C[i].polarity) :
    encodes enc C i := by
  constructor
  . intro j hile
    cases lt_or_eq_of_le hile
    case inl h' =>
      exact henc.1 _ (Nat.succ_le_of_lt h')
    case inr h' => cases h'; simp [h, hpeq]
  . intro x
    rw [henc.2]
    constructor
    . rintro ⟨j, hile, rfl⟩
      use j, (Nat.le_succ i).trans hile
    . rintro ⟨j, hile, rfl⟩
      cases lt_or_eq_of_le hile
      case inl h' => use j, Nat.succ_le_of_lt h'
      case inr h' =>
        have : enc.contains C[i].var := by
          rw [HashMap.contains_iff]; use p; exact h
        rw [henc.2] at this
        rcases this with ⟨j', hj', h''⟩
        use j', hj'
        rw [h'']; cases h'; simp

def checkTautoAux (C : IClause) : { b : Bool // b ↔ toPropTerm C = ⊤ } :=
  go C.size (le_refl _) .empty C.encodes_empty
where
  go : (i : Nat) → i ≤ C.size → (acc : HashMap Var Bool) → encodes acc C i →
      { b : Bool // b ↔ toPropTerm C = ⊤ }
    | 0,   _,  acc, hinv => ⟨false, by simp [C.not_tautology_of_encodes acc hinv]⟩
    | i+1, hi, acc, hinv =>
        have ilt := Nat.lt_of_succ_le hi
        match h: acc.find? C[i].var with
          | .none   => go i (le_of_lt ilt) _ (encodes_insert_of_find?_eq_none ilt hinv h)
          | .some p =>
              if hp: p = C[i].polarity then
                go i (le_of_lt ilt) _ (encode_of_encodes_of_find?_eq_some ilt hinv h hp)
              else
                ⟨true, by simp [tautology_of_encodes_of_find?_eq_some ilt hinv h hp]⟩

instance : DecidablePred (IClause.toPropTerm · = ⊤) :=
  fun C => match checkTautoAux C with
    | ⟨true, h⟩  => .isTrue (h.mp rfl)
    | ⟨false, h⟩ => .isFalse fun hC => nomatch h.mpr hC

/-- Check whether a clause is a tautology. The type is a hack for early-return. The clause is
tautological iff `none` is returned. -/
@[deprecated checkTautoAux]
def checkTautoAux' (C : IClause) : Option (HashMap Var Bool) :=
  C.foldlM (init := .empty) fun acc l => do
    match acc.find? l.var with
    | .none => acc.insert l.var l.polarity
    | .some p => if p ≠ l.polarity then none else acc

end IClause

/-! CNF -/

abbrev ICnf := Array IClause

namespace ICnf

def vars (φ : ICnf) : HashSet Var :=
  φ.foldr (init := .empty Var) fun C acc => acc.union C.vars

instance : ToString ICnf where
  toString C := s!"{String.intercalate " ∧ " (C.map toString).toList}"

/-! Theorems about `ICnf` -/

theorem mem_vars (φ : ICnf) (x : Var) : x ∈ φ.vars.toFinset ↔ ∃ C ∈ φ.data, x ∈ C.vars.toFinset :=
by
  simp only [vars, Array.foldr_eq_foldr_data]
  induction φ.data <;> aesop

def toPropForm (φ : ICnf) : PropForm Var :=
  φ.data.foldr (init := .tr) (fun l φ => l.toPropForm.conj φ)

def toPropTerm (φ : ICnf) : PropTerm Var :=
  φ.data.foldr (init := ⊤) (fun l φ => l.toPropTerm ⊓ φ)

@[simp]
theorem mk_toPropForm (φ : ICnf) : ⟦φ.toPropForm⟧ = φ.toPropTerm := by
  simp only [toPropForm, toPropTerm]
  induction φ.data <;> simp_all

@[simp]
theorem vars_toPropForm (φ : ICnf) : φ.toPropForm.vars = φ.vars.toFinset := by
  ext x
  simp only [mem_vars, toPropForm]
  induction φ.data <;> simp_all [PropForm.vars]

open PropTerm

theorem satisfies_iff {τ : PropAssignment Var} {φ : ICnf} :
    τ ⊨ φ.toPropTerm ↔ ∀ C ∈ φ.data, τ ⊨ C.toPropTerm := by
  rw [toPropTerm]
  induction φ.data <;> simp_all

theorem semVars_sub (φ : ICnf) : φ.toPropTerm.semVars ⊆ φ.vars.toFinset := by
  rw [← vars_toPropForm, ← mk_toPropForm]
  apply PropForm.semVars_subset_vars

end ICnf

/-! Partial assignments -/

/-- A partial assignment to propositional variables. -/
-- TODO: Using `HashMap` for this is cache-inefficient but I don't have time to verify better
-- structures rn
abbrev PartPropAssignment := HashMap Var Bool

namespace PartPropAssignment

/-- Interpret the assignment (x ↦ ⊤, y ↦ ⊥) as x ∧ ¬y, for example. -/
-- NOTE: Partial assignments really are more like formulas than they are like assignments because
-- there is no nice to way to extend one to a `PropAssignment` (i.e. a total assignment).
def toPropTerm (τ : PartPropAssignment) : PropTerm Var :=
  τ.fold (init := ⊤) fun acc x v => acc ⊓ if v then .var x else (.var x)ᶜ

instance : ToString PartPropAssignment where
  toString τ := String.intercalate " ∧ "
    (τ.fold (init := []) (f := fun acc x p => s!"{ILit.mk x p}" :: acc))

open PropTerm

theorem satisfies_iff (τ : PartPropAssignment) (σ : PropAssignment Var) :
    σ ⊨ τ.toPropTerm ↔ ∀ x p, τ.find? x = some p → σ x = p :=
  ⟨mp, mpr⟩
where
  mp := fun h => by
    intro x p? hFind
    have ⟨φ, hφ⟩ := τ.fold_of_mapsTo_of_comm
      (init := ⊤) (f := fun acc x v => acc ⊓ if v then PropTerm.var x else (PropTerm.var x)ᶜ)
      hFind ?comm
    case comm =>
      intros
      dsimp
      ac_rfl
    rw [toPropTerm, hφ] at h
    aesop

  mpr := fun h => by
    apply HashMap.foldRecOn (hInit := satisfies_tr)
    intro φ x p hφ hFind
    rw [satisfies_conj]
    refine ⟨hφ, ?_⟩
    have := h _ _ hFind
    split <;> simp [*]

end PartPropAssignment

namespace IClause

/-- Reduces a clause by a partial assignment. Returns `none` if it became satisfied,
otherwise `some C'` where `C'` is the reduced clause. -/
def reduce (C : IClause) (τ : PartPropAssignment) : Option IClause :=
  C.foldlM (init := #[]) fun acc l =>
    match τ.find? l.var with
    | some v => if v = l.polarity then none else acc
    | none => some <| acc.push l

theorem reduce_characterization (C : IClause) (σ : PartPropAssignment) :
    SatisfiesM (fun C' =>
      ∀ l ∈ C.data, (!σ.contains l.var → l ∈ C'.data) ∧
        σ.find? l.var ≠ some l.polarity) (reduce C σ) := by
  have := C.SatisfiesM_foldlM (init := #[]) (f := fun acc l =>
      match σ.find? l.var with
      | some v => if v = l.polarity then none else acc
      | none => some <| acc.push l)
    (motive := fun sz acc =>
      ∀ (i : Fin C.size), i < sz → (!σ.contains C[i].var → C[i] ∈ acc.data) ∧
        σ.find? C[i].var ≠ some C[i].polarity)
    (h0 := by simp)
    (hf := by
      simp only [SatisfiesM_Option_eq, getElem_fin]
      intro sz acc ih acc'
      split; split
      . simp
      next p hFind hP =>
        intro h i hLt; injection h with h; rw [← h]
        refine Or.elim (Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hLt)) (ih i) fun hEq => ?_
        simp only [hEq]
        refine ⟨?l, fun h => ?r⟩
        case r =>
          rw [hFind] at h
          injection h with h
          exact hP h
        case l =>
          have := HashMap.contains_iff _ _ |>.mpr ⟨_, hFind⟩
          simp_all
      next p hFind =>
        intro h i hLt; injection h with h; rw [← h]
        simp only [Array.push_data, List.mem_append, List.mem_singleton]
        refine Or.elim (Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hLt)) (fun hLt => ?_) fun hEq => ?_
          <;> aesop
      )
  dsimp [reduce]
  apply SatisfiesM.imp this
  intro C' hRed
  exact fun l hL =>
    have ⟨i, h⟩ := Array.get_of_mem_data hL
    h ▸ hRed i i.isLt

open PropTerm in
theorem reduce_eq_some (C C' : IClause) (σ : PartPropAssignment) :
    reduce C σ = some C' → C.toPropTerm ⊓ σ.toPropTerm ≤ C'.toPropTerm := by
  intro hSome
  have hRed := SatisfiesM_Option_eq.mp (reduce_characterization C σ) _ hSome
  refine entails_ext.mpr fun τ hτ => ?_
  rw [satisfies_conj] at hτ
  have ⟨l, hL, hτL⟩ := IClause.satisfies_iff.mp hτ.left
  by_cases hCont : σ.contains l.var
  next =>
    exfalso
    have ⟨p, hFind⟩ := HashMap.contains_iff _ _ |>.mp hCont
    have := PartPropAssignment.satisfies_iff _ _ |>.mp hτ.right _ _ hFind
    have : p = l.polarity := by
      rw [ILit.satisfies_iff, this] at hτL
      assumption
    exact hRed l hL |>.right (this ▸ hFind)
  next =>
    simp only [Bool.not_eq_true, Bool.bnot_eq_to_not_eq] at *
    exact IClause.satisfies_iff.mpr ⟨l, (hRed l hL).left hCont, hτL⟩

/-- When `C` is not a tautology, return the smallest assignment falsifying it. When it is not,
return an undetermined assignment. -/
def toFalsifyingAssignment (C : IClause) : PartPropAssignment :=
  C.foldl (init := .empty) fun acc l => acc.insert l.var !l.polarity

theorem toFalsifyingAssignment_characterization (C : IClause) : C.toPropTerm ≠ ⊤ →
    (∀ i : Fin C.size, C.toFalsifyingAssignment.find? C[i].var = some !C[i].polarity) ∧
    (∀ x p, C.toFalsifyingAssignment.find? x = some p → (ILit.mk x !p) ∈ C.data) := by
  intro hTauto
  have := C.foldl_induction
    (motive := fun (sz : Nat) (τ : PartPropAssignment) =>
      (∀ i : Fin C.size, i < sz → τ.find? C[i].var = some !C[i].polarity) ∧
      (∀ x p, τ.find? x = some p → (ILit.mk x !p) ∈ C.data))
    (init := .empty)
    (f := fun acc l => acc.insert l.var !l.polarity)
    (h0 := by simp)
    (hf := by
      intro sz τ ⟨ih₁, ih₂⟩
      refine ⟨?step₁, ?step₂⟩
      case step₁ =>
        intro i hLt
        cases Nat.lt_or_eq_of_le (Nat.le_of_lt_succ hLt) with
        | inl h =>
          by_cases hEq : C[sz].var = C[i].var
          . have : C[sz].polarity = C[i].polarity := by
              by_contra hPol
              have : C[sz] = -C[i] := by
                apply ILit.ext <;> simp_all
              apply hTauto
              rw [tautology_iff]
              exact ⟨C[sz], Array.get_mem_data _ _, C[i], Array.get_mem_data _ _, this⟩
            have : C[sz] = C[i] := ILit.ext hEq this
            simp_all [HashMap.find?_insert]
          . simp only [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _ |>.mpr hEq), ih₁ i h]
        | inr h =>
          simp [h]
          rw [HashMap.find?_insert _ _ LawfulBEq.rfl]
      case step₂ =>
        intro x p hFind
        by_cases hEq : C[sz].var = x
        . rw [← hEq, HashMap.find?_insert _ _ (LawfulBEq.rfl)] at hFind
          injection hFind with hFind
          rw [← hEq, ← hFind]
          simp [Array.getElem_mem_data]
        . rw [HashMap.find?_insert_of_ne _ _ (bne_iff_ne _ _|>.mpr hEq)] at hFind
          apply ih₂ _ _ hFind)
  dsimp [toFalsifyingAssignment]
  exact ⟨fun i => this.left i i.isLt, this.right⟩

theorem toFalsifyingAssignment_ext (C : IClause) : C.toPropTerm ≠ ⊤ →
    (∀ l, l ∈ C.data ↔ (toFalsifyingAssignment C).find? l.var = some !l.polarity) := by
  intro hTauto l
  have ⟨h₁, h₂⟩ := toFalsifyingAssignment_characterization C hTauto
  apply Iff.intro
  . intro hL
    have ⟨i, hI⟩ := Array.get_of_mem_data hL
    rw [← hI]
    exact h₁ i
  . intro hFind
    have := h₂ _ _ hFind
    rw [Bool.not_not, ILit.eta] at this
    exact this

theorem toPropTerm_toFalsifyingAssignment (C : IClause) : C.toPropTerm ≠ ⊤ →
    C.toFalsifyingAssignment.toPropTerm = C.toPropTermᶜ := by
  intro hTauto
  have := toFalsifyingAssignment_ext C hTauto
  ext τ
  simp only [PartPropAssignment.satisfies_iff, PropTerm.satisfies_neg, IClause.satisfies_iff,
    not_exists, not_and, ILit.satisfies_iff]
  apply Iff.intro
  . intro h l hL hτ
    have := h _ _ (this l |>.mp hL)
    simp [hτ] at this
  . intro h x p hFind
    have := this (ILit.mk x !p)
    simp only [ILit.var_mk, ILit.polarity_mk, Bool.not_not] at this
    have := h _ (this.mpr hFind)
    simp at this
    exact this

end IClause