namespace dependentProd
  inductive myNat
  | O: myNat
  | S (x: myNat): myNat
  -- sigma type: dependent pair type; (confusingly dependent product)
  -- generalization of Cartesian product ×
  -- the last one's type depend on previous's value
  -- somehow like (a: α) × (x: β(a))
  -- the notation for the type is ∑x:α, β x
  variable α: Type
  variable β: α -> Type
  variable a: α
  variable b: β a
  #check sigma.mk a b
  #check (sigma.mk a b).1
  #check (sigma.mk a b).2
  #reduce (sigma.mk a b).2
end dependentProd
namespace attributeTest
  variable {α: Type*}
  def is_prefix (l₁: list α) (l₂: list α): Prop :=
    ∃ v: list α, l₁ ++ v = l₂
  infix ` <+= `:50 := is_prefix
  attribute [simp]
  theorem list.is_prefix_refl (l: list α) : l <+= l :=
    ⟨[], by simp⟩ -- TODO ???
end attributeTest

namespace tacticsTest
  example: 3 = 3 :=
  begin
    generalize hypo: 3 = x, -- beta reduction in lambda?
    refl
  end
  -- example (p q r: Prop): p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := begin
  --   -- split,
  --   -- apply iff.intro
  --   constructor, -- they are interchangable
  -- end
end tacticsTest

namespace inductiveTypes1
  inductive weekday -- inductively define a type
  | monday | tuesday | wednesday | thursday | friday | saturday | sunday
  -- notice above accept only constructors
  -- how do I compose types?

  -- inductive good_Types: Type* -- hmm. something isn't correct -- you need type class?
  -- | ℕ | ℝ

  #check weekday.sunday
  -- below functions were auto generated & protected. i.e. they are not visible even you open namespace.
  -- this is to avoid conflicts since almost every def have them.
  #check weekday.rec -- define function over type element inductively, (def) -> ((elem) -> (result))
  #check weekday.rec_on -- define function over type element inductively, (elem) -> (def) -> (result)
  #check weekday.cases_on -- only have enumerated constructors (?)

  -- recall @ prepends terms, making their type explicit
  #check rfl
  -- #check exact -- exact is not recognizable

  namespace weekday -- automatically open it
  open weekday (renaming rec -> rec)
  def number_of_day (d: weekday): nat :=
    rec 1 2 3 4 5 6 7 d

  #reduce number_of_day tuesday

  def next (d: weekday): weekday := rec tuesday wednesday thursday friday saturday sunday monday d
  def prev (d: weekday): weekday := rec sunday monday tuesday wednesday thursday friday saturday d
  #check next thursday
  end weekday
end inductiveTypes1

namespace inductiveTypes2
  #check sum ℕ ℕ
  def func (x: ℕ ⊕ ℕ): ℕ := sum.rec (λ (t: ℕ), t) (λ (t: ℕ), t + 1) x
  #reduce func (sum.inl 3)
  #reduce func (sum.inr 3)

  #check ℕ × ℕ
  def func2 (x: ℕ × ℕ): ℕ := (prod.fst x) * (prod.snd x)
  #reduce func2 ⟨1, 3⟩

  #check option ℕ
  #check option.none

  inductive maybe (a: Type*)
  | none : maybe
  | some (x: a): maybe
  #check (maybe.some 3 : maybe ℕ)
  #check (maybe.none : maybe ℕ)
  inductive sum2 -- functionally equivalent to putting common data on top
  | inl (α : Type* )  (val : α) : sum2
  | inr (β : Type* ) (val : β) : sum2

  inductive myForall {α: Type*} (q: α -> Prop): Prop
  | intro: (Π(a: α), q a) -> myForall
  inductive myExists {α: Type*} (q: α -> Prop): Prop
  | intro: Π(a: α), q a -> myExists

    -- tactic mode hypothesis := all type that have evidence
    -- recall def. equality can be converted to Prop identity by refl.
  inductive foo: Type
  | bar1 : ℕ -> ℕ -> foo
  | bar2 : ℕ -> ℕ -> ℕ -> foo
  def silly (x: foo) : ℕ :=
  begin
    cases x with a b c d e, exact b, exact e
  end

end inductiveTypes2

namespace wtf
  universe u
  variables {α β: Type u}
  inductive image_of (f: α -> β): β -> Type u
  | imf : Π a, image_of (f a) -- to define an element of image_of f a type, it suffice to

  -- same thing by prop & subtype
  def isImageOf (f: α -> β) (b: β) := ∃x: α, f x = b
  def my_image_of (f: α -> β ):= {b: β // isImageOf f b}

  -- def can be used in proving as well as identies
  def pl (a: nat) (b: nat) := a + b
  example: pl 2 2 = 4 := begin
    rw pl,
  end
end wtf

namespace hidden
  class myInhabited (a: Type*) := (default: a)
  instance propIsInhabited: myInhabited Prop := ⟨true⟩
  def default (a: Type*) [s: myInhabited a]: a := s.default
  #reduce default Prop
  -- #check (nat.no_confusion)
  def reduce_one: ℕ -> option ℕ
  | 0            := option.none
  | (nat.succ a) := option.some a
  def reduce_one_2 (x: nat) (nz: ¬ x = 0): ℕ

end hidden

#check (ℕ : Type 0)
namespace unconfused
  -- [imo] no_confusion is to prove two things are not same if they are different constructors of same inductive type.
  -- see https://xenaproject.wordpress.com/2018/03/24/no-confusion-over-no_confusion/
  inductive myType
  | A
  | B
  def myType_isEqual (a b: myType) : Prop :=
    myType.rec (myType.rec true false b) (myType.rec false true b) a
  theorem myType_no_confusion (u v: myType) (pe: u = v): myType_isEqual u v :=
  begin
    rw pe, cases v; unfold myType_isEqual,
  end
end unconfused

-- namespace typeuniverses
-- #check (nat: Type 0)
-- inductive myType: Type 2 | none | some: test2 -> myType
-- inductive test2: Type 2 | some: myType -> test2

-- end typeuniverses

namespace structures
  structure point2d (num_t: Type*) := mk :: (x: num_t) (y: num_t)
  #print prefix structures.point2d
  #reduce (@point2d.mk ℕ 2 3)
  #reduce (point2d.mk 2 3) -- structure argument auto marked as implicit (the compiler claims it is always derivable from constructors)
  #reduce {point2d . x := 3, y := 2} -- alt symbol
  #reduce point2d.x

  universe u
  structure point (a: Type u) := mk :: (x: a) (y : a)
  structure {v} point2 (a: Type v) := mk :: (x: a) (y: a) -- the universe variable
  def {uu} pts (x: Type uu) := x

  structure point3d (num_t: Type*) extends point2d num_t := mk :: (z: num_t)
  def p1 := (@point3d.mk ℕ (point2d.mk 1 2) 5)
  def p2 := {point3d . x := 1, y := 2, z := 3}
  #reduce p2.x -- shouldn't this equal to point3d.x .. p2 ..?

end structures

namespace someDoubts
  def

end someDoubts


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

Coinductive formalization of unbounded computations.
-/
import data.stream
import tactic.basic

universes u v w

/-
coinductive computation (α : Type u) : Type u
| return : α → computation α
| think : computation α → computation α
-/

/-- `computation α` is the type of unbounded computations returning `α`.
  An element of `computation α` is an infinite sequence of `option α` such
  that if `f n = some a` for some `n` then it is constantly `some a` after that. -/
def computation (α : Type u) : Type u :=
{ f : stream (option α) // ∀ {n a}, f n = some a → f (n+1) = some a }

namespace computation
variables {α : Type u} {β : Type v} {γ : Type w}

-- constructors
/-- `return a` is the computation that immediately terminates with result `a`. -/
def return (a : α) : computation α := ⟨stream.const (some a), λn a', id⟩

instance : has_coe_t α (computation α) := ⟨return⟩ -- note [use has_coe_t]

/-- `think c` is the computation that delays for one "tick" and then performs
  computation `c`. -/
def think (c : computation α) : computation α :=
⟨none :: c.1, λn a h, by {cases n with n, contradiction, exact c.2 h}⟩

/-- `thinkN c n` is the computation that delays for `n` ticks and then performs
  computation `c`. -/
def thinkN (c : computation α) : ℕ → computation α
| 0 := c
| (n+1) := think (thinkN n)

-- check for immediate result
/-- `head c` is the first step of computation, either `some a` if `c = return a`
  or `none` if `c = think c'`. -/
def head (c : computation α) : option α := c.1.head

-- one step of computation
/-- `tail c` is the remainder of computation, either `c` if `c = return a`
  or `c'` if `c = think c'`. -/
def tail (c : computation α) : computation α :=
⟨c.1.tail, λ n a, let t := c.2 in t⟩

/-- `empty α` is the computation that never returns, an infinite sequence of
  `think`s. -/
def empty (α) : computation α := ⟨stream.const none, λn a', id⟩

instance : inhabited (computation α) := ⟨empty _⟩

/-- `run_for c n` evaluates `c` for `n` steps and returns the result, or `none`
  if it did not terminate after `n` steps. -/
def run_for : computation α → ℕ → option α := subtype.val

/-- `destruct c` is the destructor for `computation α` as a coinductive type.
  It returns `inl a` if `c = return a` and `inr c'` if `c = think c'`. -/
def destruct (c : computation α) : α ⊕ computation α :=
match c.1 0 with
| none := sum.inr (tail c)
| some a := sum.inl a
end

/-- `run c` is an unsound meta function that runs `c` to completion, possibly
  resulting in an infinite loop in the VM. -/
meta def run : computation α → α | c :=
match destruct c with
| sum.inl a := a
| sum.inr ca := run ca
end

theorem destruct_eq_ret {s : computation α} {a : α} :
  destruct s = sum.inl a → s = return a :=
begin
  dsimp [destruct],
  induction f0 : s.1 0; intro h,
  { contradiction },
  { apply subtype.eq, funext n,
    induction n with n IH,
    { injection h with h', rwa h' at f0 },
    { exact s.2 IH } }
end

theorem destruct_eq_think {s : computation α} {s'} :
  destruct s = sum.inr s' → s = think s' :=
begin
  dsimp [destruct],
  induction f0 : s.1 0 with a'; intro h,
  { injection h with h', rw ←h',
    cases s with f al,
    apply subtype.eq, dsimp [think, tail],
    rw ←f0, exact (stream.eta f).symm },
  { contradiction }
end

@[simp]

@[simp] theorem destruct_think : ∀ s : computation α, destruct (think s) = sum.inr s
| ⟨f, al⟩ := rfl

@[simp] theorem destruct_empty : destruct (empty α) = sum.inr (empty α) := rfl

@[simp] theorem head_ret (a : α) : head (return a) = some a := rfl

@[simp] theorem head_think (s : computation α) : head (think s) = none := rfl

@[simp] theorem head_empty : head (empty α) = none := rfl

@[simp] theorem tail_ret (a : α) : tail (return a) = return a := rfl

@[simp] theorem tail_think (s : computation α) : tail (think s) = s :=
by cases s with f al; apply subtype.eq; dsimp [tail, think]; rw [stream.tail_cons]

@[simp] theorem tail_empty : tail (empty α) = empty α := rfl

theorem think_empty : empty α = think (empty α) :=
destruct_eq_think destruct_empty

def cases_on {C : computation α → Sort v} (s : computation α)
  (h1 : ∀ a, C (return a)) (h2 : ∀ s, C (think s)) : C s := begin
  induction H : destruct s with v v,
  { rw destruct_eq_ret H, apply h1 },
  { cases v with a s', rw destruct_eq_think H, apply h2 }
end

def corec.F (f : β → α ⊕ β) : α ⊕ β → option α × (α ⊕ β)
| (sum.inl a) := (some a, sum.inl a)
| (sum.inr b) := (match f b with
  | sum.inl a := some a
  | sum.inr b' := none
  end, f b)

/-- `corec f b` is the corecursor for `computation α` as a coinductive type.
  If `f b = inl a` then `corec f b = return a`, and if `f b = inl b'` then
  `corec f b = think (corec f b')`. -/
def corec (f : β → α ⊕ β) (b : β) : computation α :=
begin
  refine ⟨stream.corec' (corec.F f) (sum.inr b), λn a' h, _⟩,
  rw stream.corec'_eq,
  change stream.corec' (corec.F f) (corec.F f (sum.inr b)).2 n = some a',
  revert h, generalize : sum.inr b = o, revert o,
  induction n with n IH; intro o,
  { change (corec.F f o).1 = some a' → (corec.F f (corec.F f o).2).1 = some a',
    cases o with a b; intro h, { exact h },
    dsimp [corec.F] at h, dsimp [corec.F],
    cases f b with a b', { exact h },
    { contradiction } },
  { rw [stream.corec'_eq (corec.F f) (corec.F f o).2,
        stream.corec'_eq (corec.F f) o],
    exact IH (corec.F f o).2 }
end

/-- left map of `⊕` -/
def lmap (f : α → β) : α ⊕ γ → β ⊕ γ
| (sum.inl a) := sum.inl (f a)
| (sum.inr b) := sum.inr b

/-- right map of `⊕` -/
def rmap (f : β → γ) : α ⊕ β → α ⊕ γ
| (sum.inl a) := sum.inl a
| (sum.inr b) := sum.inr (f b)
attribute [simp] lmap rmap

@[simp] lemma corec_eq (f : β → α ⊕ β) (b : β) :
  destruct (corec f b) = rmap (corec f) (f b) :=
begin
  dsimp [corec, destruct],
  change stream.corec' (corec.F f) (sum.inr b) 0 with corec.F._match_1 (f b),
  induction h : f b with a b', { refl },
  dsimp [corec.F, destruct],
  apply congr_arg, apply subtype.eq,
  dsimp [corec, tail],
  rw [stream.corec'_eq, stream.tail_cons],
  dsimp [corec.F], rw h
end

section bisim
  variable (R : computation α → computation α → Prop)

  local infix ~ := R

  def bisim_o : α ⊕ computation α → α ⊕ computation α → Prop
  | (sum.inl a) (sum.inl a') := a = a'
  | (sum.inr s) (sum.inr s') := R s s'
  | _           _            := false
  attribute [simp] bisim_o

  def is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → bisim_o R (destruct s₁) (destruct s₂)

  -- If two computations are bisimilar, then they are equal
  theorem eq_of_bisim (bisim : is_bisimulation R) {s₁ s₂} (r : s₁ ~ s₂) : s₁ = s₂ :=
  begin
    apply subtype.eq,
    apply stream.eq_of_bisim (λx y, ∃ s s' : computation α, s.1 = x ∧ s'.1 = y ∧ R s s'),
    dsimp [stream.is_bisimulation],
    intros t₁ t₂ e,
    exact match t₁, t₂, e with ._, ._, ⟨s, s', rfl, rfl, r⟩ :=
      suffices head s = head s' ∧ R (tail s) (tail s'), from
      and.imp id (λr, ⟨tail s, tail s',
        by cases s; refl, by cases s'; refl, r⟩) this,
      begin
        have := bisim r, revert r this,
        apply cases_on s _ _; intros; apply cases_on s' _ _; intros; intros r this,
        { constructor, dsimp at this, rw this, assumption },
        { rw [destruct_ret, destruct_think] at this,
          exact false.elim this },
        { rw [destruct_ret, destruct_think] at this,
          exact false.elim this },
        { simp at this, simp [*] }
      end
    end,
    exact ⟨s₁, s₂, rfl, rfl, r⟩
  end
end bisim

-- It's more of a stretch to use ∈ for this relation, but it
-- asserts that the computation limits to the given value.
protected def mem (a : α) (s : computation α) := some a ∈ s.1

instance : has_mem α (computation α) := ⟨computation.mem⟩

theorem le_stable (s : computation α) {a m n} (h : m ≤ n) :
  s.1 m = some a → s.1 n = some a :=
by {cases s with f al, induction h with n h IH, exacts [id, λ h2, al (IH h2)]}

theorem mem_unique {s : computation α} {a b : α} : a ∈ s → b ∈ s → a = b
| ⟨m, ha⟩ ⟨n, hb⟩ := by injection
  (le_stable s (le_max_left m n) ha.symm).symm.trans
  (le_stable s (le_max_right m n) hb.symm)

theorem mem.left_unique : relator.left_unique ((∈) : α → computation α → Prop) :=
⟨λ a s b, mem_unique⟩

/-- `terminates s` asserts that the computation `s` eventually terminates with some value. -/
class terminates (s : computation α) : Prop := (term : ∃ a, a ∈ s)

theorem terminates_iff (s : computation α) : terminates s ↔ ∃ a, a ∈ s :=
⟨λ h, h.1, terminates.mk⟩

theorem terminates_of_mem {s : computation α} {a : α} (h : a ∈ s) : terminates s :=
⟨⟨a, h⟩⟩

theorem terminates_def (s : computation α) : terminates s ↔ ∃ n, (s.1 n).is_some :=
⟨λ ⟨⟨a, n, h⟩⟩, ⟨n, by {dsimp [stream.nth] at h, rw ←h, exact rfl}⟩,
 λ ⟨n, h⟩, ⟨⟨option.get h, n, (option.eq_some_of_is_some h).symm⟩⟩⟩

theorem ret_mem (a : α) : a ∈ return a :=
exists.intro 0 rfl

theorem eq_of_ret_mem {a a' : α} (h : a' ∈ return a) : a' = a :=
mem_unique h (ret_mem _)

instance ret_terminates (a : α) : terminates (return a) :=
terminates_of_mem (ret_mem _)

theorem think_mem {s : computation α} {a} : a ∈ s → a ∈ think s
| ⟨n, h⟩ := ⟨n+1, h⟩

instance think_terminates (s : computation α) :
  ∀ [terminates s], terminates (think s)
| ⟨⟨a, n, h⟩⟩ := ⟨⟨a, n+1, h⟩⟩

theorem of_think_mem {s : computation α} {a} : a ∈ think s → a ∈ s
| ⟨n, h⟩ := by {cases n with n', contradiction, exact ⟨n', h⟩}

theorem of_think_terminates {s : computation α} :
  terminates (think s) → terminates s
| ⟨⟨a, h⟩⟩ := ⟨⟨a, of_think_mem h⟩⟩

theorem not_mem_empty (a : α) : a ∉ empty α :=
λ ⟨n, h⟩, by clear _fun_match; contradiction

theorem not_terminates_empty : ¬ terminates (empty α) :=
λ ⟨⟨a, h⟩⟩, not_mem_empty a h

theorem eq_empty_of_not_terminates {s} (H : ¬ terminates s) : s = empty α :=
begin
  apply subtype.eq, funext n,
  induction h : s.val n, {refl},
  refine absurd _ H, exact ⟨⟨_, _, h.symm⟩⟩
end

theorem thinkN_mem {s : computation α} {a} : ∀ n, a ∈ thinkN s n ↔ a ∈ s
| 0 := iff.rfl
| (n+1) := iff.trans ⟨of_think_mem, think_mem⟩ (thinkN_mem n)

instance thinkN_terminates (s : computation α) :
  ∀ [terminates s] n, terminates (thinkN s n)
| ⟨⟨a, h⟩⟩ n := ⟨⟨a, (thinkN_mem n).2 h⟩⟩

theorem of_thinkN_terminates (s : computation α) (n) :
  terminates (thinkN s n) → terminates s
| ⟨⟨a, h⟩⟩ := ⟨⟨a, (thinkN_mem _).1 h⟩⟩

/-- `promises s a`, or `s ~> a`, asserts that although the computation `s`
  may not terminate, if it does, then the result is `a`. -/
def promises (s : computation α) (a : α) : Prop := ∀ ⦃a'⦄, a' ∈ s → a = a'

infix ` ~> `:50 := promises

theorem mem_promises {s : computation α} {a : α} : a ∈ s → s ~> a :=
λ h a', mem_unique h

theorem empty_promises (a : α) : empty α ~> a :=
λ a' h, absurd h (not_mem_empty _)

section get
variables (s : computation α) [h : terminates s]
include s h

/-- `length s` gets the number of steps of a terminating computation -/
def length : ℕ := nat.find ((terminates_def _).1 h)

/-- `get s` returns the result of a terminating computation -/
def get : α := option.get (nat.find_spec $ (terminates_def _).1 h)

theorem get_mem : get s ∈ s :=
exists.intro (length s) (option.eq_some_of_is_some _).symm

theorem get_eq_of_mem {a} : a ∈ s → get s = a :=
mem_unique (get_mem _)

theorem mem_of_get_eq {a} : get s = a → a ∈ s :=
by intro h; rw ←h; apply get_mem

@[simp] theorem get_think : get (think s) = get s :=
get_eq_of_mem _ $ let ⟨n, h⟩ := get_mem s in ⟨n+1, h⟩

@[simp] theorem get_thinkN (n) : get (thinkN s n) = get s :=
get_eq_of_mem _ $ (thinkN_mem _).2 (get_mem _)

theorem get_promises : s ~> get s := λ a, get_eq_of_mem _

theorem mem_of_promises {a} (p : s ~> a) : a ∈ s :=
by { casesI h, cases h with a' h, rw p h, exact h }

theorem get_eq_of_promises {a} : s ~> a → get s = a :=
get_eq_of_mem _ ∘ mem_of_promises _

end get

/-- `results s a n` completely characterizes a terminating computation:
  it asserts that `s` terminates after exactly `n` steps, with result `a`. -/
def results (s : computation α) (a : α) (n : ℕ) :=
∃ (h : a ∈ s), @length _ s (terminates_of_mem h) = n

theorem results_of_terminates (s : computation α) [T : terminates s] :
  results s (get s) (length s) :=
⟨get_mem _, rfl⟩

theorem results_of_terminates' (s : computation α) [T : terminates s] {a} (h : a ∈ s) :
  results s a (length s) :=
by rw ←get_eq_of_mem _ h; apply results_of_terminates

theorem results.mem {s : computation α} {a n} : results s a n → a ∈ s
| ⟨m, _⟩ := m

theorem results.terminates {s : computation α} {a n} (h : results s a n) : terminates s :=
terminates_of_mem h.mem

theorem results.length {s : computation α} {a n} [T : terminates s] :
  results s a n → length s = n
| ⟨_, h⟩ := h

theorem results.val_unique {s : computation α} {a b m n}
  (h1 : results s a m) (h2 : results s b n) : a = b :=
mem_unique h1.mem h2.mem

theorem results.len_unique {s : computation α} {a b m n}
  (h1 : results s a m) (h2 : results s b n) : m = n :=
by haveI := h1.terminates; haveI := h2.terminates; rw [←h1.length, h2.length]

theorem exists_results_of_mem {s : computation α} {a} (h : a ∈ s) : ∃ n, results s a n :=
by haveI := terminates_of_mem h; exact ⟨_, results_of_terminates' s h⟩

@[simp] theorem get_ret (a : α) : get (return a) = a :=
get_eq_of_mem _ ⟨0, rfl⟩

@[simp] theorem length_ret (a : α) : length (return a) = 0 :=
let h := computation.ret_terminates a in
nat.eq_zero_of_le_zero $ nat.find_min' ((terminates_def (return a)).1 h) rfl

theorem results_ret (a : α) : results (return a) a 0 :=
⟨_, length_ret _⟩

@[simp] theorem length_think (s : computation α) [h : terminates s] :
  length (think s) = length s + 1 :=
begin
  apply le_antisymm,
  { exact nat.find_min' _ (nat.find_spec ((terminates_def _).1 h)) },
  { have : (option.is_some ((think s).val (length (think s))) : Prop) :=
      nat.find_spec ((terminates_def _).1 s.think_terminates),
    cases length (think s) with n,
    { contradiction },
    { apply nat.succ_le_succ, apply nat.find_min', apply this } }
end

theorem results_think {s : computation α} {a n}
  (h : results s a n) : results (think s) a (n + 1) :=
by haveI := h.terminates; exact ⟨think_mem h.mem, by rw [length_think, h.length]⟩

theorem of_results_think {s : computation α} {a n}
  (h : results (think s) a n) : ∃ m, results s a m ∧ n = m + 1 :=
begin
  haveI := of_think_terminates h.terminates,
  have := results_of_terminates' _ (of_think_mem h.mem),
  exact ⟨_, this, results.len_unique h (results_think this)⟩,
end

@[simp] theorem results_think_iff {s : computation α} {a n} :
  results (think s) a (n + 1) ↔ results s a n :=
⟨λ h, let ⟨n', r, e⟩ := of_results_think h in by injection e with h'; rwa h',
results_think⟩

theorem results_thinkN {s : computation α} {a m} :
  ∀ n, results s a m → results (thinkN s n) a (m + n)
| 0     h := h
| (n+1) h := results_think (results_thinkN n h)

theorem results_thinkN_ret (a : α) (n) : results (thinkN (return a) n) a n :=
by have := results_thinkN n (results_ret a); rwa nat.zero_add at this

@[simp] theorem length_thinkN (s : computation α) [h : terminates s] (n) :
  length (thinkN s n) = length s + n :=
(results_thinkN n (results_of_terminates _)).length

theorem eq_thinkN {s : computation α} {a n} (h : results s a n) :
  s = thinkN (return a) n :=
begin
  revert s,
  induction n with n IH; intro s;
  apply cases_on s (λ a', _) (λ s, _); intro h,
  { rw ←eq_of_ret_mem h.mem, refl },
  { cases of_results_think h with n h, cases h, contradiction },
  { have := h.len_unique (results_ret _), contradiction },
  { rw IH (results_think_iff.1 h), refl }
end

theorem eq_thinkN' (s : computation α) [h : terminates s] :
  s = thinkN (return (get s)) (length s) :=
eq_thinkN (results_of_terminates _)

def mem_rec_on {C : computation α → Sort v} {a s} (M : a ∈ s)
  (h1 : C (return a)) (h2 : ∀ s, C s → C (think s)) : C s :=
begin
  haveI T := terminates_of_mem M,
  rw [eq_thinkN' s, get_eq_of_mem s M],
  generalize : length s = n,
  induction n with n IH, exacts [h1, h2 _ IH]
end

def terminates_rec_on {C : computation α → Sort v} (s) [terminates s]
  (h1 : ∀ a, C (return a)) (h2 : ∀ s, C s → C (think s)) : C s :=
mem_rec_on (get_mem s) (h1 _) h2

/-- Map a function on the result of a computation. -/
def map (f : α → β) : computation α → computation β
| ⟨s, al⟩ := ⟨s.map (λo, option.cases_on o none (some ∘ f)),
λn b, begin
  dsimp [stream.map, stream.nth],
  induction e : s n with a; intro h,
  { contradiction }, { rw [al e, ←h] }
end⟩

def bind.G : β ⊕ computation β → β ⊕ computation α ⊕ computation β
| (sum.inl b)   := sum.inl b
| (sum.inr cb') := sum.inr $ sum.inr cb'

def bind.F (f : α → computation β) :
  computation α ⊕ computation β → β ⊕ computation α ⊕ computation β
| (sum.inl ca) :=
  match destruct ca with
  | sum.inl a := bind.G $ destruct (f a)
  | sum.inr ca' := sum.inr $ sum.inl ca'
  end
| (sum.inr cb) := bind.G $ destruct cb

/-- Compose two computations into a monadic `bind` operation. -/
def bind (c : computation α) (f : α → computation β) : computation β :=
corec (bind.F f) (sum.inl c)

instance : has_bind computation := ⟨@bind⟩

theorem has_bind_eq_bind {β} (c : computation α) (f : α → computation β) :
  c >>= f = bind c f := rfl

/-- Flatten a computation of computations into a single computation. -/
def join (c : computation (computation α)) : computation α := c >>= id

@[simp] theorem map_ret (f : α → β) (a) : map f (return a) = return (f a) := rfl

@[simp] theorem map_think (f : α → β) : ∀ s, map f (think s) = think (map f s)
| ⟨s, al⟩ := by apply subtype.eq; dsimp [think, map]; rw stream.map_cons

@[simp]
theorem destruct_map (f : α → β) (s) : destruct (map f s) = lmap f (rmap (map f) (destruct s)) :=
by apply s.cases_on; intro; simp

@[simp] theorem map_id : ∀ (s : computation α), map id s = s
| ⟨f, al⟩ := begin
  apply subtype.eq; simp [map, function.comp],
  have e : (@option.rec α (λ_, option α) none some) = id,
  { ext ⟨⟩; refl },
  simp [e, stream.map_id]
end

theorem map_comp (f : α → β) (g : β → γ) :
  ∀ (s : computation α), map (g ∘ f) s = map g (map f s)
| ⟨s, al⟩ := begin
  apply subtype.eq; dsimp [map],
  rw stream.map_map,
  apply congr_arg (λ f : _ → option γ, stream.map f s),
  ext ⟨⟩; refl
end

@[simp] theorem ret_bind (a) (f : α → computation β) :
  bind (return a) f = f a :=
begin
  apply eq_of_bisim (λc₁ c₂,
         c₁ = bind (return a) f ∧ c₂ = f a ∨
         c₁ = corec (bind.F f) (sum.inr c₂)),
  { intros c₁ c₂ h,
    exact match c₁, c₂, h with
    | ._, ._, or.inl ⟨rfl, rfl⟩ := begin
      simp [bind, bind.F],
      cases destruct (f a) with b cb; simp [bind.G]
    end
    | ._, c, or.inr rfl := begin
      simp [bind.F],
      cases destruct c with b cb; simp [bind.G]
    end end },
  { simp }
end

@[simp] theorem think_bind (c) (f : α → computation β) :
  bind (think c) f = think (bind c f) :=
destruct_eq_think $ by simp [bind, bind.F]

@[simp] theorem bind_ret (f : α → β) (s) : bind s (return ∘ f) = map f s :=
begin
  apply eq_of_bisim (λc₁ c₂, c₁ = c₂ ∨
         ∃ s, c₁ = bind s (return ∘ f) ∧ c₂ = map f s),
  { intros c₁ c₂ h,
    exact match c₁, c₂, h with
    | _, _, or.inl (eq.refl c) := begin cases destruct c with b cb; simp end
    | _, _, or.inr ⟨s, rfl, rfl⟩ := begin
      apply cases_on s; intros s; simp,
      exact or.inr ⟨s, rfl, rfl⟩
    end end },
  { exact or.inr ⟨s, rfl, rfl⟩ }
end

@[simp] theorem bind_ret' (s : computation α) : bind s return = s :=
by rw bind_ret; change (λ x : α, x) with @id α; rw map_id

@[simp] theorem bind_assoc (s : computation α) (f : α → computation β) (g : β → computation γ) :
  bind (bind s f) g = bind s (λ (x : α), bind (f x) g) :=
begin
  apply eq_of_bisim (λc₁ c₂, c₁ = c₂ ∨
         ∃ s, c₁ = bind (bind s f) g ∧ c₂ = bind s (λ (x : α), bind (f x) g)),
  { intros c₁ c₂ h,
    exact match c₁, c₂, h with
    | _, _, or.inl (eq.refl c) := by cases destruct c with b cb; simp
    | ._, ._, or.inr ⟨s, rfl, rfl⟩ := begin
      apply cases_on s; intros s; simp,
      { generalize : f s = fs,
        apply cases_on fs; intros t; simp,
        { cases destruct (g t) with b cb; simp } },
      { exact or.inr ⟨s, rfl, rfl⟩ }
    end end },
  { exact or.inr ⟨s, rfl, rfl⟩ }
end

theorem results_bind {s : computation α} {f : α → computation β} {a b m n}
  (h1 : results s a m) (h2 : results (f a) b n) : results (bind s f) b (n + m) :=
begin
  have := h1.mem, revert m,
  apply mem_rec_on this _ (λ s IH, _); intros m h1,
  { rw [ret_bind], rw h1.len_unique (results_ret _), exact h2 },
  { rw [think_bind], cases of_results_think h1 with m' h, cases h with h1 e,
    rw e, exact results_think (IH h1) }
end

theorem mem_bind {s : computation α} {f : α → computation β} {a b}
  (h1 : a ∈ s) (h2 : b ∈ f a) : b ∈ bind s f :=
let ⟨m, h1⟩ := exists_results_of_mem h1,
    ⟨n, h2⟩ := exists_results_of_mem h2 in (results_bind h1 h2).mem

instance terminates_bind (s : computation α) (f : α → computation β)
  [terminates s] [terminates (f (get s))] :
  terminates (bind s f) :=
terminates_of_mem (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem get_bind (s : computation α) (f : α → computation β)
  [terminates s] [terminates (f (get s))] :
  get (bind s f) = get (f (get s)) :=
get_eq_of_mem _ (mem_bind (get_mem s) (get_mem (f (get s))))

@[simp] theorem length_bind (s : computation α) (f : α → computation β)
  [T1 : terminates s] [T2 : terminates (f (get s))] :
  length (bind s f) = length (f (get s)) + length s :=
(results_of_terminates _).len_unique $
results_bind (results_of_terminates _) (results_of_terminates _)

theorem of_results_bind {s : computation α} {f : α → computation β} {b k} :
  results (bind s f) b k →
  ∃ a m n, results s a m ∧ results (f a) b n ∧ k = n + m :=
begin
  induction k with n IH generalizing s;
  apply cases_on s (λ a, _) (λ s', _); intro e,
  { simp [thinkN] at e, refine ⟨a, _, _, results_ret _, e, rfl⟩ },
  { have := congr_arg head (eq_thinkN e), contradiction },
  { simp at e, refine ⟨a, _, n+1, results_ret _, e, rfl⟩ },
  { simp at e, exact let ⟨a, m, n', h1, h2, e'⟩ := IH e in
    by rw e'; exact ⟨a, m.succ, n', results_think h1, h2, rfl⟩ }
end

theorem exists_of_mem_bind {s : computation α} {f : α → computation β} {b}
  (h : b ∈ bind s f) : ∃ a ∈ s, b ∈ f a :=
let ⟨k, h⟩ := exists_results_of_mem h,
    ⟨a, m, n, h1, h2, e⟩ := of_results_bind h in ⟨a, h1.mem, h2.mem⟩

theorem bind_promises {s : computation α} {f : α → computation β} {a b}
  (h1 : s ~> a) (h2 : f a ~> b) : bind s f ~> b :=
λ b' bB, begin
  rcases exists_of_mem_bind bB with ⟨a', a's, ba'⟩,
  rw ←h1 a's at ba', exact h2 ba'
end

instance : monad computation :=
{ map  := @map,
  pure := @return,
  bind := @bind }

instance : is_lawful_monad computation :=
{ id_map := @map_id,
  bind_pure_comp_eq_map := @bind_ret,
  pure_bind := @ret_bind,
  bind_assoc := @bind_assoc }

theorem has_map_eq_map {β} (f : α → β) (c : computation α) : f <$> c = map f c := rfl

@[simp] theorem return_def (a) : (_root_.return a : computation α) = return a := rfl

@[simp] theorem map_ret' {α β} : ∀ (f : α → β) (a), f <$> return a = return (f a) := map_ret
@[simp] theorem map_think' {α β} : ∀ (f : α → β) s, f <$> think s = think (f <$> s) := map_think

theorem mem_map (f : α → β) {a} {s : computation α} (m : a ∈ s) : f a ∈ map f s :=
by rw ←bind_ret; apply mem_bind m; apply ret_mem

theorem exists_of_mem_map {f : α → β} {b : β} {s : computation α} (h : b ∈ map f s) :
   ∃ a, a ∈ s ∧ f a = b :=
by rw ←bind_ret at h; exact
let ⟨a, as, fb⟩ := exists_of_mem_bind h in ⟨a, as, mem_unique (ret_mem _) fb⟩

instance terminates_map (f : α → β) (s : computation α) [terminates s] : terminates (map f s) :=
by rw ←bind_ret; apply_instance

theorem terminates_map_iff (f : α → β) (s : computation α) :
  terminates (map f s) ↔ terminates s :=
⟨λ ⟨⟨a, h⟩⟩, let ⟨b, h1, _⟩ := exists_of_mem_map h in ⟨⟨_, h1⟩⟩,
 @computation.terminates_map _ _ _ _⟩

-- Parallel computation
/-- `c₁ <|> c₂` calculates `c₁` and `c₂` simultaneously, returning
  the first one that gives a result. -/
def orelse (c₁ c₂ : computation α) : computation α :=
@computation.corec α (computation α × computation α)
  (λ⟨c₁, c₂⟩, match destruct c₁ with
  | sum.inl a := sum.inl a
  | sum.inr c₁' := match destruct c₂ with
    | sum.inl a := sum.inl a
    | sum.inr c₂' := sum.inr (c₁', c₂')
    end
  end) (c₁, c₂)

instance : alternative computation :=
{ orelse := @orelse, failure := @empty, ..computation.monad }

@[simp] theorem ret_orelse (a : α) (c₂ : computation α) :
  (return a <|> c₂) = return a :=
destruct_eq_ret $ by unfold has_orelse.orelse; simp [orelse]

@[simp] theorem orelse_ret (c₁ : computation α) (a : α) :
  (think c₁ <|> return a) = return a :=
destruct_eq_ret $ by unfold has_orelse.orelse; simp [orelse]

@[simp] theorem orelse_think (c₁ c₂ : computation α) :
  (think c₁ <|> think c₂) = think (c₁ <|> c₂) :=
destruct_eq_think $ by unfold has_orelse.orelse; simp [orelse]

@[simp] theorem empty_orelse (c) : (empty α <|> c) = c :=
begin
  apply eq_of_bisim (λc₁ c₂, (empty α <|> c₂) = c₁) _ rfl,
  intros s' s h, rw ←h,
  apply cases_on s; intros s; rw think_empty; simp,
  rw ←think_empty,
end

@[simp] theorem orelse_empty (c : computation α) : (c <|> empty α) = c :=
begin
  apply eq_of_bisim (λc₁ c₂, (c₂ <|> empty α) = c₁) _ rfl,
  intros s' s h, rw ←h,
  apply cases_on s; intros s; rw think_empty; simp,
  rw←think_empty,
end

/-- `c₁ ~ c₂` asserts that `c₁` and `c₂` either both terminate with the same result,
  or both loop forever. -/
def equiv (c₁ c₂ : computation α) : Prop := ∀ a, a ∈ c₁ ↔ a ∈ c₂

infix ~ := equiv

@[refl] theorem equiv.refl (s : computation α) : s ~ s := λ_, iff.rfl

@[symm] theorem equiv.symm {s t : computation α} : s ~ t → t ~ s :=
λh a, (h a).symm

@[trans] theorem equiv.trans {s t u : computation α} : s ~ t → t ~ u → s ~ u :=
λh1 h2 a, (h1 a).trans (h2 a)

theorem equiv.equivalence : equivalence (@equiv α) :=
⟨@equiv.refl _, @equiv.symm _, @equiv.trans _⟩

theorem equiv_of_mem {s t : computation α} {a} (h1 : a ∈ s) (h2 : a ∈ t) : s ~ t :=
λa', ⟨λma, by rw mem_unique ma h1; exact h2,
      λma, by rw mem_unique ma h2; exact h1⟩

theorem terminates_congr {c₁ c₂ : computation α}
  (h : c₁ ~ c₂) : terminates c₁ ↔ terminates c₂ :=
by simp only [terminates_iff, exists_congr h]

theorem promises_congr {c₁ c₂ : computation α}
  (h : c₁ ~ c₂) (a) : c₁ ~> a ↔ c₂ ~> a :=
forall_congr (λa', imp_congr (h a') iff.rfl)

theorem get_equiv {c₁ c₂ : computation α} (h : c₁ ~ c₂)
  [terminates c₁] [terminates c₂] : get c₁ = get c₂ :=
get_eq_of_mem _ $ (h _).2 $ get_mem _

theorem think_equiv (s : computation α) : think s ~ s :=
λ a, ⟨of_think_mem, think_mem⟩

theorem thinkN_equiv (s : computation α) (n) : thinkN s n ~ s :=
λ a, thinkN_mem n

theorem bind_congr {s1 s2 : computation α} {f1 f2 : α → computation β}
  (h1 : s1 ~ s2) (h2 : ∀ a, f1 a ~ f2 a) : bind s1 f1 ~ bind s2 f2 :=
λ b, ⟨λh, let ⟨a, ha, hb⟩ := exists_of_mem_bind h in
        mem_bind ((h1 a).1 ha) ((h2 a b).1 hb),
      λh, let ⟨a, ha, hb⟩ := exists_of_mem_bind h in
        mem_bind ((h1 a).2 ha) ((h2 a b).2 hb)⟩

theorem equiv_ret_of_mem {s : computation α} {a} (h : a ∈ s) : s ~ return a :=
equiv_of_mem h (ret_mem _)

/-- `lift_rel R ca cb` is a generalization of `equiv` to relations other than
  equality. It asserts that if `ca` terminates with `a`, then `cb` terminates with
  some `b` such that `R a b`, and if `cb` terminates with `b` then `ca` terminates
  with some `a` such that `R a b`. -/
def lift_rel (R : α → β → Prop) (ca : computation α) (cb : computation β) : Prop :=
(∀ {a}, a ∈ ca → ∃ {b}, b ∈ cb ∧ R a b) ∧
 ∀ {b}, b ∈ cb → ∃ {a}, a ∈ ca ∧ R a b

theorem lift_rel.swap (R : α → β → Prop) (ca : computation α) (cb : computation β) :
  lift_rel (function.swap R) cb ca ↔ lift_rel R ca cb :=
and_comm _ _

theorem lift_eq_iff_equiv (c₁ c₂ : computation α) : lift_rel (=) c₁ c₂ ↔ c₁ ~ c₂ :=
⟨λ⟨h1, h2⟩ a,
  ⟨λ a1, let ⟨b, b2, ab⟩ := h1 a1 in by rwa ab,
   λ a2, let ⟨b, b1, ab⟩ := h2 a2 in by rwa ←ab⟩,
λe, ⟨λ a a1, ⟨a, (e _).1 a1, rfl⟩, λ a a2, ⟨a, (e _).2 a2, rfl⟩⟩⟩

theorem lift_rel.refl (R : α → α → Prop) (H : reflexive R) : reflexive (lift_rel R) :=
λ s, ⟨λ a as, ⟨a, as, H a⟩, λ b bs, ⟨b, bs, H b⟩⟩

theorem lift_rel.symm (R : α → α → Prop) (H : symmetric R) : symmetric (lift_rel R) :=
λ s1 s2 ⟨l, r⟩,
 ⟨λ a a2, let ⟨b, b1, ab⟩ := r a2 in ⟨b, b1, H ab⟩,
  λ a a1, let ⟨b, b2, ab⟩ := l a1 in ⟨b, b2, H ab⟩⟩

theorem lift_rel.trans (R : α → α → Prop) (H : transitive R) : transitive (lift_rel R) :=
λ s1 s2 s3 ⟨l1, r1⟩ ⟨l2, r2⟩,
 ⟨λ a a1, let ⟨b, b2, ab⟩ := l1 a1, ⟨c, c3, bc⟩ := l2 b2 in ⟨c, c3, H ab bc⟩,
  λ c c3, let ⟨b, b2, bc⟩ := r2 c3, ⟨a, a1, ab⟩ := r1 b2 in ⟨a, a1, H ab bc⟩⟩

theorem lift_rel.equiv (R : α → α → Prop) : equivalence R → equivalence (lift_rel R)
| ⟨refl, symm, trans⟩ :=
  ⟨lift_rel.refl R refl, lift_rel.symm R symm, lift_rel.trans R trans⟩

theorem lift_rel.imp {R S : α → β → Prop} (H : ∀ {a b}, R a b → S a b) (s t) :
  lift_rel R s t → lift_rel S s t | ⟨l, r⟩ :=
⟨λ a as, let ⟨b, bt, ab⟩ := l as in ⟨b, bt, H ab⟩,
 λ b bt, let ⟨a, as, ab⟩ := r bt in ⟨a, as, H ab⟩⟩

theorem terminates_of_lift_rel {R : α → β → Prop} {s t} :
 lift_rel R s t → (terminates s ↔ terminates t) | ⟨l, r⟩ :=
⟨λ ⟨⟨a, as⟩⟩, let ⟨b, bt, ab⟩ := l as in ⟨⟨b, bt⟩⟩,
 λ ⟨⟨b, bt⟩⟩, let ⟨a, as, ab⟩ := r bt in ⟨⟨a, as⟩⟩⟩

theorem rel_of_lift_rel {R : α → β → Prop} {ca cb} :
 lift_rel R ca cb → ∀ {a b}, a ∈ ca → b ∈ cb → R a b
| ⟨l, r⟩ a b ma mb :=
  let ⟨b', mb', ab'⟩ := l ma in by rw mem_unique mb mb'; exact ab'

theorem lift_rel_of_mem {R : α → β → Prop} {a b ca cb}
  (ma : a ∈ ca) (mb : b ∈ cb) (ab : R a b) : lift_rel R ca cb :=
⟨λ a' ma', by rw mem_unique ma' ma; exact ⟨b, mb, ab⟩,
 λ b' mb', by rw mem_unique mb' mb; exact ⟨a, ma, ab⟩⟩

theorem exists_of_lift_rel_left {R : α → β → Prop} {ca cb}
  (H : lift_rel R ca cb) {a} (h : a ∈ ca) : ∃ {b}, b ∈ cb ∧ R a b :=
H.left h

theorem exists_of_lift_rel_right {R : α → β → Prop} {ca cb}
  (H : lift_rel R ca cb) {b} (h : b ∈ cb) : ∃ {a}, a ∈ ca ∧ R a b :=
H.right h

theorem lift_rel_def {R : α → β → Prop} {ca cb} : lift_rel R ca cb ↔
  (terminates ca ↔ terminates cb) ∧ ∀ {a b}, a ∈ ca → b ∈ cb → R a b :=
⟨λh, ⟨terminates_of_lift_rel h, λ a b ma mb,
  let ⟨b', mb', ab⟩ := h.left ma in by rwa mem_unique mb mb'⟩,
λ⟨l, r⟩,
 ⟨λ a ma, let ⟨⟨b, mb⟩⟩ := l.1 ⟨⟨_, ma⟩⟩ in ⟨b, mb, r ma mb⟩,
  λ b mb, let ⟨⟨a, ma⟩⟩ := l.2 ⟨⟨_, mb⟩⟩ in ⟨a, ma, r ma mb⟩⟩⟩

theorem lift_rel_bind {δ} (R : α → β → Prop) (S : γ → δ → Prop)
  {s1 : computation α} {s2 : computation β}
  {f1 : α → computation γ} {f2 : β → computation δ}
  (h1 : lift_rel R s1 s2) (h2 : ∀ {a b}, R a b → lift_rel S (f1 a) (f2 b))
  : lift_rel S (bind s1 f1) (bind s2 f2) :=
let ⟨l1, r1⟩ := h1 in
⟨λ c cB,
  let ⟨a, a1, c₁⟩ := exists_of_mem_bind cB,
      ⟨b, b2, ab⟩ := l1 a1,
      ⟨l2, r2⟩ := h2 ab,
      ⟨d, d2, cd⟩ := l2 c₁ in
  ⟨_, mem_bind b2 d2, cd⟩,
λ d dB,
  let ⟨b, b1, d1⟩ := exists_of_mem_bind dB,
      ⟨a, a2, ab⟩ := r1 b1,
      ⟨l2, r2⟩ := h2 ab,
      ⟨c, c₂, cd⟩ := r2 d1 in
  ⟨_, mem_bind a2 c₂, cd⟩⟩

@[simp] theorem lift_rel_return_left (R : α → β → Prop) (a : α) (cb : computation β) :
  lift_rel R (return a) cb ↔ ∃ {b}, b ∈ cb ∧ R a b :=
⟨λ⟨l, r⟩, l (ret_mem _),
 λ⟨b, mb, ab⟩,
  ⟨λ a' ma', by rw eq_of_ret_mem ma'; exact ⟨b, mb, ab⟩,
   λ b' mb', ⟨_, ret_mem _, by rw mem_unique mb' mb; exact ab⟩⟩⟩

@[simp] theorem lift_rel_return_right (R : α → β → Prop) (ca : computation α) (b : β) :
  lift_rel R ca (return b) ↔ ∃ {a}, a ∈ ca ∧ R a b :=
by rw [lift_rel.swap, lift_rel_return_left]

@[simp] theorem lift_rel_return (R : α → β → Prop) (a : α) (b : β) :
  lift_rel R (return a) (return b) ↔ R a b :=
by rw [lift_rel_return_left]; exact
⟨λ⟨b', mb', ab'⟩, by rwa eq_of_ret_mem mb' at ab',
 λab, ⟨_, ret_mem _, ab⟩⟩

@[simp] theorem lift_rel_think_left (R : α → β → Prop) (ca : computation α) (cb : computation β) :
  lift_rel R (think ca) cb ↔ lift_rel R ca cb :=
and_congr (forall_congr $ λb, imp_congr ⟨of_think_mem, think_mem⟩ iff.rfl)
 (forall_congr $ λb, imp_congr iff.rfl $
    exists_congr $ λ b, and_congr ⟨of_think_mem, think_mem⟩ iff.rfl)

@[simp] theorem lift_rel_think_right (R : α → β → Prop) (ca : computation α) (cb : computation β) :
  lift_rel R ca (think cb) ↔ lift_rel R ca cb :=
by rw [←lift_rel.swap R, ←lift_rel.swap R]; apply lift_rel_think_left

theorem lift_rel_mem_cases {R : α → β → Prop} {ca cb}
  (Ha : ∀ a ∈ ca, lift_rel R ca cb)
  (Hb : ∀ b ∈ cb, lift_rel R ca cb) : lift_rel R ca cb :=
⟨λ a ma, (Ha _ ma).left ma, λ b mb, (Hb _ mb).right mb⟩

theorem lift_rel_congr {R : α → β → Prop} {ca ca' : computation α} {cb cb' : computation β}
  (ha : ca ~ ca') (hb : cb ~ cb') : lift_rel R ca cb ↔ lift_rel R ca' cb' :=
and_congr
  (forall_congr $ λ a, imp_congr (ha _) $ exists_congr $ λ b, and_congr (hb _) iff.rfl)
  (forall_congr $ λ b, imp_congr (hb _) $ exists_congr $ λ a, and_congr (ha _) iff.rfl)

theorem lift_rel_map {δ} (R : α → β → Prop) (S : γ → δ → Prop)
  {s1 : computation α} {s2 : computation β}
  {f1 : α → γ} {f2 : β → δ}
  (h1 : lift_rel R s1 s2) (h2 : ∀ {a b}, R a b → S (f1 a) (f2 b))
  : lift_rel S (map f1 s1) (map f2 s2) :=
by rw [←bind_ret, ←bind_ret]; apply lift_rel_bind _ _ h1; simp; exact @h2

theorem map_congr (R : α → α → Prop) (S : β → β → Prop)
  {s1 s2 : computation α} {f : α → β}
  (h1 : s1 ~ s2) : map f s1 ~ map f s2 :=
by rw [←lift_eq_iff_equiv];
   exact lift_rel_map eq _ ((lift_eq_iff_equiv _ _).2 h1) (λ a b, congr_arg _)

def lift_rel_aux (R : α → β → Prop)
  (C : computation α → computation β → Prop) :
  α ⊕ computation α → β ⊕ computation β → Prop
| (sum.inl a)  (sum.inl b)  := R a b
| (sum.inl a)  (sum.inr cb) := ∃ {b}, b ∈ cb ∧ R a b
| (sum.inr ca) (sum.inl b)  := ∃ {a}, a ∈ ca ∧ R a b
| (sum.inr ca) (sum.inr cb) := C ca cb
attribute [simp] lift_rel_aux

@[simp] lemma lift_rel_aux.ret_left (R : α → β → Prop)
  (C : computation α → computation β → Prop) (a cb) :
  lift_rel_aux R C (sum.inl a) (destruct cb) ↔ ∃ {b}, b ∈ cb ∧ R a b :=
begin
  apply cb.cases_on (λ b, _) (λ cb, _),
  { exact ⟨λ h, ⟨_, ret_mem _, h⟩, λ ⟨b', mb, h⟩,
    by rw [mem_unique (ret_mem _) mb]; exact h⟩ },
  { rw [destruct_think],
    exact ⟨λ ⟨b, h, r⟩, ⟨b, think_mem h, r⟩,
           λ ⟨b, h, r⟩, ⟨b, of_think_mem h, r⟩⟩ }
end

theorem lift_rel_aux.swap (R : α → β → Prop) (C) (a b) :
  lift_rel_aux (function.swap R) (function.swap C) b a = lift_rel_aux R C a b :=
by cases a with a ca; cases b with b cb; simp only [lift_rel_aux]

@[simp] lemma lift_rel_aux.ret_right (R : α → β → Prop)
  (C : computation α → computation β → Prop) (b ca) :
  lift_rel_aux R C (destruct ca) (sum.inl b) ↔ ∃ {a}, a ∈ ca ∧ R a b :=
by rw [←lift_rel_aux.swap, lift_rel_aux.ret_left]

theorem lift_rel_rec.lem {R : α → β → Prop} (C : computation α → computation β → Prop)
  (H : ∀ {ca cb}, C ca cb → lift_rel_aux R C (destruct ca) (destruct cb))
  (ca cb) (Hc : C ca cb) (a) (ha : a ∈ ca) : lift_rel R ca cb :=
begin
  revert cb, refine mem_rec_on ha _ (λ ca' IH, _);
  intros cb Hc; have h := H Hc,
  { simp at h, simp [h] },
  { have h := H Hc, simp, revert h, apply cb.cases_on (λ b, _) (λ cb', _);
    intro h; simp at h; simp [h], exact IH _ h }
end

theorem lift_rel_rec {R : α → β → Prop} (C : computation α → computation β → Prop)
  (H : ∀ {ca cb}, C ca cb → lift_rel_aux R C (destruct ca) (destruct cb))
  (ca cb) (Hc : C ca cb) : lift_rel R ca cb :=
lift_rel_mem_cases (lift_rel_rec.lem C @H ca cb Hc) (λ b hb,
 (lift_rel.swap _ _ _).2 $
 lift_rel_rec.lem (function.swap C)
   (λ cb ca h, cast (lift_rel_aux.swap _ _ _ _).symm $ H h)
   cb ca Hc b hb)

end computation


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Group.abelian
import Mathlib.category_theory.limits.shapes.images
import Mathlib.category_theory.limits.types
import Mathlib.PostPort

namespace Mathlib

/-!
# The category of commutative additive groups has images.

Note that we don't need to register any of the constructions here as instances, because we get them
from the fact that `AddCommGroup` is an abelian category.
-/

namespace AddCommGroup

-- Note that because `injective_of_mono` is currently only proved in `Type 0`,

-- we restrict to the lowest universe here for now.

/-- the image of a morphism in AddCommGroup is just the bundling of `add_monoid_hom.range f` -/
def image {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) : AddCommGroup :=
  of ↥(add_monoid_hom.range f)

/-- the inclusion of `image f` into the target -/
def image.ι {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) : image f ⟶ H :=
  add_subgroup.subtype (add_monoid_hom.range f)

protected instance image.ι.category_theory.mono {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.mono (image.ι f) :=
  category_theory.concrete_category.mono_of_injective (image.ι f) subtype.val_injective

/-- the corestriction map to the image -/
def factor_thru_image {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) : G ⟶ image f :=
  add_monoid_hom.to_range f

theorem image.fac {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    factor_thru_image f ≫ image.ι f = f :=
  ext G H (factor_thru_image f ≫ image.ι f) f
    fun (x : ↥G) => Eq.refl (coe_fn (factor_thru_image f ≫ image.ι f) x)

/-- the universal property for the image factorisation -/
def image.lift {G : AddCommGroup} {H : AddCommGroup} {f : G ⟶ H}
    (F' : category_theory.limits.mono_factorisation f) :
    image f ⟶ category_theory.limits.mono_factorisation.I F' :=
  add_monoid_hom.mk
    (fun (x : ↥(image f)) =>
      coe_fn (category_theory.limits.mono_factorisation.e F')
        (subtype.val
          (classical.indefinite_description (fun (x_1 : ↥G) => coe_fn f x_1 = subtype.val x)
            sorry)))
    sorry sorry

theorem image.lift_fac {G : AddCommGroup} {H : AddCommGroup} {f : G ⟶ H}
    (F' : category_theory.limits.mono_factorisation f) :
    image.lift F' ≫ category_theory.limits.mono_factorisation.m F' = image.ι f :=
  sorry

/-- the factorisation of any morphism in AddCommGroup through a mono. -/
def mono_factorisation {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.limits.mono_factorisation f :=
  category_theory.limits.mono_factorisation.mk (image f) (image.ι f) (factor_thru_image f)

/-- the factorisation of any morphism in AddCommGroup through a mono has the universal property of
the image. -/
def is_image {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.limits.is_image (mono_factorisation f) :=
  category_theory.limits.is_image.mk image.lift

/--
The categorical image of a morphism in `AddCommGroup`
agrees with the usual group-theoretical range.
-/
def image_iso_range {G : AddCommGroup} {H : AddCommGroup} (f : G ⟶ H) :
    category_theory.limits.image f ≅ of ↥(add_monoid_hom.range f) :=
  category_theory.limits.is_image.iso_ext (category_theory.limits.image.is_image f) (is_image f)

end Mathlib


import GMLInit.Data.Set.Basic

namespace Set
open Set.Notation

protected abbrev insert (s : Set α) (a : α) := Set.pure a ∪ s

protected abbrev insertIf (s : Set α) (a : α) (p : Prop) := Set.pureIf a p ∪ s

theorem mem_insert_iff_eq_or_mem (a : α) (s : Set α) : x ∈ s.insert a ↔ x = a ∨ x ∈ s := Iff.rfl

theorem mem_insertIf_iff_eq_and_cond_or_mem (a : α) (s : Set α) : x ∈ s.insertIf a p ↔ (x = a ∧ p) ∨ x ∈ s := Iff.rfl

theorem mem_insert_self (a : α) (s : Set α) : a ∈ s.insert a := Or.inl rfl

theorem mem_insertIf_self_of_cond (a : α) (s : Set α) {p : Prop} (h : p) : a ∈ s.insertIf a p := Or.inl ⟨rfl, h⟩

theorem mem_insert_of_mem (a : α) (s : Set α) : x ∈ s → x ∈ s.insert a := Or.inr

theorem mem_insertIf_of_mem (a : α) (s : Set α) {p : Prop} : x ∈ s → x ∈ s.insertIf a p := Or.inr

theorem insertIf_true_eq_insert (a : α) (s : Set α) : s.insertIf a True = s.insert a := by
  apply Set.ext
  intro x
  constr
  · intro
    | Or.inl ⟨_,_⟩ => left; assumption
    | Or.inr _ => right; assumption
  · intro
    | Or.inl _ => left; constr; assumption; trivial
    | Or.inr _ => right; assumption

theorem insert_idem (a : α) (s : Set α) : (s.insert a).insert a = s.insert a :=
  calc
  _ = (Set.pure a ∪ Set.pure a) ∪ s := by rw [union_assoc]
  _ = Set.pure a ∪ s := by rw [union_idem]

theorem insertIf_idem (a : α) (s : Set α) : (s.insertIf a p).insertIf a p = s.insertIf a p:=
  calc
  _ = (Set.pureIf a p ∪ Set.pureIf a p) ∪ s := by rw [union_assoc]
  _ = Set.pureIf a p ∪ s := by rw [union_idem]

theorem insert_comm (a₁ a₂ : α) (s : Set α) : (s.insert a₁).insert a₂ = (s.insert a₂).insert a₁ :=
  calc
  _ = (Set.pure a₂ ∪ Set.pure a₁) ∪ s := by rw [union_assoc]
  _ = (Set.pure a₁ ∪ Set.pure a₂) ∪ s := by rw [union_comm (Set.pure a₁) (Set.pure a₂)]
  _ = Set.pure a₁ ∪ (Set.pure a₂ ∪ s) := by rw [union_assoc]

theorem insertIf_comm (a₁ a₂ : α) (s : Set α) : (s.insertIf a₁ p₁).insertIf a₂ p₂ = (s.insertIf a₂ p₂).insertIf a₁ p₁ :=
  calc
  _ = (Set.pureIf a₂ p₂ ∪ Set.pureIf a₁ p₁) ∪ s := by rw [union_assoc]
  _ = (Set.pureIf a₁ p₁ ∪ Set.pureIf a₂ p₂) ∪ s := by rw [union_comm (Set.pureIf a₁ p₁) (Set.pureIf a₂ p₂)]
  _ = Set.pureIf a₁ p₁ ∪ (Set.pureIf a₂ p₂ ∪ s) := by rw [union_assoc]

theorem insert_union_left (a : α) (s t : Set α) : s.insert a ∪ t = (s ∪ t).insert a :=
  calc
  _ = Set.pure a ∪ (s ∪ t) := by rw [union_assoc]

theorem insert_union_right (a : α) (s t : Set α) : s ∪ t.insert a = (s ∪ t).insert a :=
  calc
  _ = (s ∪ Set.pure a) ∪ t := by rw [union_assoc]
  _ = (Set.pure a ∪ s) ∪ t := by rw [union_comm (Set.pure a) s]
  _ = Set.pure a ∪ (s ∪ t) := by rw [union_assoc]

theorem insertIf_union_left (a : α) (s t : Set α) : s.insertIf a p ∪ t = (s ∪ t).insertIf a p :=
  calc
  _ = Set.pureIf a p ∪ (s ∪ t) := by rw [union_assoc]

theorem insertIf_union_right (a : α) (s t : Set α) : s ∪ t.insertIf a p = (s ∪ t).insertIf a p :=
  calc
  _ = (s ∪ Set.pureIf a p) ∪ t := by rw [union_assoc]
  _ = (Set.pureIf a p ∪ s) ∪ t := by rw [union_comm (Set.pureIf a p) s]
  _ = Set.pureIf a p ∪ (s ∪ t) := by rw [union_assoc]

theorem insert_inter_left (a : α) (s t : Set α) : s.insert a ∩ t = (s ∩ t).insertIf a (a ∈ t) :=
  calc
  _ = (Set.pure a ∩ t) ∪ (s ∩ t) := by rw [inter_distrib_right]
  _ = Set.pureIf a (a ∈ t) ∪ (s ∩ t) := by rw [pure_inter]

theorem insert_inter_right (a : α) (s t : Set α) : s ∩ t.insert a = (s ∩ t).insertIf a (a ∈ s) :=
  calc
  _ = (s ∩ Set.pure a) ∪ (s ∩ t) := by rw [inter_distrib_left]
  _ = Set.pureIf a (a ∈ s) ∪ (s ∩ t) := by rw [inter_pure]

theorem insertIf_inter_left (a : α) (p : Prop) (s t : Set α) : s.insertIf a p ∩ t = (s ∩ t).insertIf a (p ∧ a ∈ t) :=
  calc
  _ = (Set.pureIf a p ∩ t) ∪ (s ∩ t) := by rw [inter_distrib_right]
  _ = Set.pureIf a (p ∧ a ∈ t) ∪ (s ∩ t) := by rw [pureIf_inter]

theorem insertIf_inter_right (a : α) (p : Prop) (s t : Set α) : s ∩ t.insertIf a p = (s ∩ t).insertIf a (p ∧ a ∈ s) :=
  calc
  _ = (s ∩ Set.pureIf a p) ∪ (s ∩ t) := by rw [inter_distrib_left]
  _ = Set.pureIf a (p ∧ a ∈ s) ∪ (s ∩ t) := by rw [inter_pureIf]

theorem insert_map (f : α → β) (a : α) (s : Set α) : (s.insert a).map f = (s.map f).insert (f a) :=
  calc
  _ = (Set.pure a).map f ∪ s.map f := by rw [union_map]
  _ = Set.pure (f a) ∪ s.map f := by rw [Set.map_pure]

theorem insertIf_map (f : α → β) (a : α) (p : Prop) (s : Set α) : (s.insertIf a p).map f = (s.map f).insertIf (f a) p :=
  calc
  _ = (Set.pureIf a p).map f ∪ s.map f := by rw [union_map]
  _ = Set.pureIf (f a) p ∪ s.map f := by rw [Set.map_pureIf]

theorem insert_bind (f : α → Set β) (a : α) (s : Set α) : (s.insert a).bind f = f a ∪ s.bind f :=
  calc
  _ = (Set.pure a).bind f ∪ s.bind f := by rw [union_bind]
  _ = f a ∪ s.bind f := by rw [Set.pure_bind]

theorem insertIf_bind (f : α → Set β) (a : α) (p : Prop) (s : Set α) : (s.insertIf a p).bind f = (f a ∩ Set.const p) ∪ s.bind f :=
  calc
  _ = (Set.pureIf a p).bind f ∪ s.bind f := by rw [union_bind]
  _ = (f a ∩ Set.const p) ∪ s.bind f := by rw [Set.pureIf_bind]

theorem insert_join (s : Set (Set α)) (t : Set α) : (s.insert t).join = t ∪ s.join := insert_bind id t s

theorem insertIf_join (s : Set (Set α)) (t : Set α) (p : Prop) : (s.insertIf t p).join = (t ∩ Set.const p) ∪ s.join := insertIf_bind id t p s

theorem insert_seq (f : Set (α → β)) (a : α) (s : Set α) : Set.seq f (s.insert a) = f.map (λ f => f a) ∪ Set.seq f s := by
  clean unfold Set.seq
  apply Set.ext
  intro y
  constr
  · intro ⟨f,hf,h⟩
    clean at h
    rw [insert_map] at h
    match h with
    | Or.inl h => cases h; left; exists f
    | Or.inr ⟨x,hxs,h⟩ => cases h; right; exists f; constr; assumption; exists x
  · intro
    | Or.inl ⟨f,hf,h⟩ => cases h; exists f; constr; assumption; exists a; constr; left; rfl; rfl
    | Or.inr ⟨f,hf,x,hx,h⟩ => cases h; exists f; constr; assumption; exists x; constr; right; assumption; rfl

theorem insertIf_seq (f : Set (α → β)) (a : α) (p : Prop) (s : Set α) : Set.seq f (s.insertIf a p) = (f.map (λ f => f a) ∩ Set.const p) ∪ Set.seq f s := by
  clean unfold Set.seq
  apply Set.ext
  intro y
  constr
  · intro ⟨f,hf,h⟩
    clean at h
    rw [insertIf_map] at h
    match h with
    | Or.inl ⟨h, hp⟩ =>
      left
      constr
      · exists f
        constr
        · exact hf
        · exact h.symm
      · exact hp
    | Or.inr ⟨x,hxs,h⟩ =>
      right
      exists f
      constr
      · exact hf
      · exists x
  · intro
    | Or.inl ⟨⟨f,hf,h⟩,hp⟩ =>
      exists f
      constr
      · exact hf
      · exists a
        constr
        · left
          constr
          · rfl
          · exact hp
        · exact h
    | Or.inr ⟨f,hf,x,hx,h⟩ =>
      exists f
      constr
      · exact hf
      · exists x
        constr
        · right
          exact hx
        · exact h

end Set


/-
Copyright (c) 2018 Sean Leather. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sean Leather, Mario Carneiro

! This file was ported from Lean 3 source module data.finmap
! leanprover-community/mathlib commit cea83e192eae2d368ab2b500a0975667da42c920
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.AList
import Mathlib.Data.Finset.Sigma
import Mathlib.Data.Part

/-!
# Finite maps over `Multiset`
-/

universe u v w

open List

variable {α : Type u} {β : α → Type v}

/-! ### Multisets of sigma types-/

namespace Multiset

/-- Multiset of keys of an association multiset. -/
def keys (s : Multiset (Sigma β)) : Multiset α :=
  s.map Sigma.fst
#align multiset.keys Multiset.keys

@[simp]
theorem coe_keys {l : List (Sigma β)} : keys (l : Multiset (Sigma β)) = (l.keys : Multiset α) :=
  rfl
#align multiset.coe_keys Multiset.coe_keys

-- Porting note: Fixed Nodupkeys -> NodupKeys
/-- `NodupKeys s` means that `s` has no duplicate keys. -/
def NodupKeys (s : Multiset (Sigma β)) : Prop :=
  Quot.liftOn s List.NodupKeys fun _ _ p => propext <| perm_nodupKeys p
#align multiset.nodupkeys Multiset.NodupKeys

@[simp]
theorem coe_nodupKeys {l : List (Sigma β)} : @NodupKeys α β l ↔ l.NodupKeys :=
  Iff.rfl
#align multiset.coe_nodupkeys Multiset.coe_nodupKeys

lemma nodup_keys {m : Multiset (Σ a, β a)} : m.keys.Nodup ↔ m.NodupKeys := by
  rcases m with ⟨l⟩; rfl

alias nodup_keys ↔ _ NodupKeys.nodup_keys

protected lemma NodupKeys.nodup {m : Multiset (Σ a, β a)} (h : m.NodupKeys) : m.Nodup :=
  h.nodup_keys.of_map _

end Multiset

/-! ### Finmap -/

/-- `Finmap β` is the type of finite maps over a multiset. It is effectively
  a quotient of `AList β` by permutation of the underlying list. -/
structure Finmap (β : α → Type v) : Type max u v where
  /-- The underlying `Multiset` of an `Finmap` -/
  entries : Multiset (Sigma β)
  /-- There are no duplicate keys in `entries` -/
  nodupKeys : entries.NodupKeys
#align finmap Finmap

/-- The quotient map from `AList` to `Finmap`. -/
def AList.toFinmap (s : AList β) : Finmap β :=
  ⟨s.entries, s.nodupKeys⟩
#align alist.to_finmap AList.toFinmap

local notation:arg "⟦" a "⟧" => AList.toFinmap a

theorem AList.toFinmap_eq {s₁ s₂ : AList β} :
    toFinmap s₁ = toFinmap s₂ ↔ s₁.entries ~ s₂.entries := by
  cases s₁
  cases s₂
  simp [AList.toFinmap]
#align alist.to_finmap_eq AList.toFinmap_eq

@[simp]
theorem AList.toFinmap_entries (s : AList β) : ⟦s⟧.entries = s.entries :=
  rfl
#align alist.to_finmap_entries AList.toFinmap_entries

/-- Given `l : List (Sigma β)`, create a term of type `Finmap β` by removing
entries with duplicate keys. -/
def List.toFinmap [DecidableEq α] (s : List (Sigma β)) : Finmap β :=
  s.toAList.toFinmap
#align list.to_finmap List.toFinmap

namespace Finmap

open AList

lemma nodup_entries (f : Finmap β) : f.entries.Nodup := f.nodupKeys.nodup

/-! ### Lifting from AList -/

/-- Lift a permutation-respecting function on `AList` to `Finmap`. -/
-- @[elab_as_elim] Porting note: we can't add `elab_as_elim` attr in this type
def liftOn {γ} (s : Finmap β) (f : AList β → γ)
    (H : ∀ a b : AList β, a.entries ~ b.entries → f a = f b) : γ := by
  refine'
    (Quotient.liftOn s.entries
      (fun (l : List (Sigma β)) => (⟨_, fun nd => f ⟨l, nd⟩⟩ : Part γ))
      (fun l₁ l₂ p => Part.ext' (perm_nodupKeys p) _) : Part γ).get _
  · exact fun h1 h2 => H _ _ p
  · have := s.nodupKeys
    -- Porting note: `revert` required because `rcases` behaves differently
    revert this
    rcases s.entries with ⟨l⟩
    exact id

#align finmap.lift_on Finmap.liftOn

@[simp]
theorem liftOn_toFinmap {γ} (s : AList β) (f : AList β → γ) (H) : liftOn ⟦s⟧ f H = f s := by
  cases s
  rfl
#align finmap.lift_on_to_finmap Finmap.liftOn_toFinmap

/-- Lift a permutation-respecting function on 2 `AList`s to 2 `Finmap`s. -/
-- @[elab_as_elim] Porting note: we can't add `elab_as_elim` attr in this type
def liftOn₂ {γ} (s₁ s₂ : Finmap β) (f : AList β → AList β → γ)
    (H : ∀ a₁ b₁ a₂ b₂ : AList β,
      a₁.entries ~ a₂.entries → b₁.entries ~ b₂.entries → f a₁ b₁ = f a₂ b₂) : γ :=
  liftOn s₁ (fun l₁ => liftOn s₂ (f l₁) fun b₁ b₂ p => H _ _ _ _ (Perm.refl _) p) fun a₁ a₂ p => by
    have H' : f a₁ = f a₂ := funext fun _ => H _ _ _ _ p (Perm.refl _)
    simp only [H']
#align finmap.lift_on₂ Finmap.liftOn₂

@[simp]
theorem liftOn₂_toFinmap {γ} (s₁ s₂ : AList β) (f : AList β → AList β → γ) (H) :
    liftOn₂ ⟦s₁⟧ ⟦s₂⟧ f H = f s₁ s₂ :=
      by cases s₁ ; cases s₂ ; rfl
#align finmap.lift_on₂_to_finmap Finmap.liftOn₂_toFinmap

/-! ### Induction -/

@[elab_as_elim]
theorem induction_on {C : Finmap β → Prop} (s : Finmap β) (H : ∀ a : AList β, C ⟦a⟧) : C s := by
  rcases s with ⟨⟨a⟩, h⟩ ; exact H ⟨a, h⟩
#align finmap.induction_on Finmap.induction_on

@[elab_as_elim]
theorem induction_on₂ {C : Finmap β → Finmap β → Prop} (s₁ s₂ : Finmap β)
    (H : ∀ a₁ a₂ : AList β, C ⟦a₁⟧ ⟦a₂⟧) : C s₁ s₂ :=
  induction_on s₁ fun l₁ => induction_on s₂ fun l₂ => H l₁ l₂
#align finmap.induction_on₂ Finmap.induction_on₂

@[elab_as_elim]
theorem induction_on₃ {C : Finmap β → Finmap β → Finmap β → Prop} (s₁ s₂ s₃ : Finmap β)
    (H : ∀ a₁ a₂ a₃ : AList β, C ⟦a₁⟧ ⟦a₂⟧ ⟦a₃⟧) : C s₁ s₂ s₃ :=
  induction_on₂ s₁ s₂ fun l₁ l₂ => induction_on s₃ fun l₃ => H l₁ l₂ l₃
#align finmap.induction_on₃ Finmap.induction_on₃

/-! ### extensionality -/

@[ext]
theorem ext : ∀ {s t : Finmap β}, s.entries = t.entries → s = t
  | ⟨l₁, h₁⟩, ⟨l₂, _⟩, H => by congr
#align finmap.ext Finmap.ext

@[simp]

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
instance : Membership α (Finmap β) :=
  ⟨fun a s => a ∈ s.entries.keys⟩

theorem mem_def {a : α} {s : Finmap β} : a ∈ s ↔ a ∈ s.entries.keys :=
  Iff.rfl
#align finmap.mem_def Finmap.mem_def

@[simp]
theorem mem_toFinmap {a : α} {s : AList β} : a ∈ toFinmap s ↔ a ∈ s :=
  Iff.rfl
#align finmap.mem_to_finmap Finmap.mem_toFinmap

/-! ### keys -/

/-- The set of keys of a finite map. -/
def keys (s : Finmap β) : Finset α :=
  ⟨s.entries.keys, s.nodupKeys.nodup_keys⟩
#align finmap.keys Finmap.keys

@[simp]
theorem keys_val (s : AList β) : (keys ⟦s⟧).val = s.keys :=
  rfl
#align finmap.keys_val Finmap.keys_val

@[simp]
theorem keys_ext {s₁ s₂ : AList β} : keys ⟦s₁⟧ = keys ⟦s₂⟧ ↔ s₁.keys ~ s₂.keys := by
  simp [keys, AList.keys]
#align finmap.keys_ext Finmap.keys_ext

theorem mem_keys {a : α} {s : Finmap β} : a ∈ s.keys ↔ a ∈ s :=
  induction_on s fun _ => AList.mem_keys
#align finmap.mem_keys Finmap.mem_keys

/-! ### empty -/

/-- The empty map. -/
instance : EmptyCollection (Finmap β) :=
  ⟨⟨0, nodupKeys_nil⟩⟩

instance : Inhabited (Finmap β) :=
  ⟨∅⟩

@[simp]
theorem empty_toFinmap : (⟦∅⟧ : Finmap β) = ∅ :=
  rfl
#align finmap.empty_to_finmap Finmap.empty_toFinmap

@[simp]
theorem toFinmap_nil [DecidableEq α] : ([].toFinmap : Finmap β) = ∅ :=
  rfl
#align finmap.to_finmap_nil Finmap.toFinmap_nil

theorem not_mem_empty {a : α} : a ∉ (∅ : Finmap β) :=
  Multiset.not_mem_zero a
#align finmap.not_mem_empty Finmap.not_mem_empty

@[simp]
theorem keys_empty : (∅ : Finmap β).keys = ∅ :=
  rfl
#align finmap.keys_empty Finmap.keys_empty

/-! ### singleton -/

/-- The singleton map. -/
def singleton (a : α) (b : β a) : Finmap β :=
  ⟦AList.singleton a b⟧
#align finmap.singleton Finmap.singleton

@[simp]
theorem keys_singleton (a : α) (b : β a) : (singleton a b).keys = {a} :=
  rfl
#align finmap.keys_singleton Finmap.keys_singleton

@[simp]
theorem mem_singleton (x y : α) (b : β y) : x ∈ singleton y b ↔ x = y := by
  simp only [singleton] ; erw [mem_cons, mem_nil_iff, or_false_iff]
#align finmap.mem_singleton Finmap.mem_singleton

section

variable [DecidableEq α]

instance decidableEq [∀ a, DecidableEq (β a)] : DecidableEq (Finmap β)
  | _, _ => decidable_of_iff _ ext_iff
#align finmap.has_decidable_eq Finmap.decidableEq

/-! ### lookup -/

/-- Look up the value associated to a key in a map. -/
def lookup (a : α) (s : Finmap β) : Option (β a) :=
  liftOn s (AList.lookup a) fun _ _ => perm_lookup
#align finmap.lookup Finmap.lookup

@[simp]
theorem lookup_toFinmap (a : α) (s : AList β) : lookup a ⟦s⟧ = s.lookup a :=
  rfl
#align finmap.lookup_to_finmap Finmap.lookup_toFinmap

-- Porting note: renaming to `List.dlookup` since `List.lookup` already exists
@[simp]
theorem dlookup_list_toFinmap (a : α) (s : List (Sigma β)) : lookup a s.toFinmap = s.dlookup a := by
  rw [List.toFinmap, lookup_toFinmap, lookup_to_alist]
#align finmap.lookup_list_to_finmap Finmap.dlookup_list_toFinmap

@[simp]
theorem lookup_empty (a) : lookup a (∅ : Finmap β) = none :=
  rfl
#align finmap.lookup_empty Finmap.lookup_empty

theorem lookup_isSome {a : α} {s : Finmap β} : (s.lookup a).isSome ↔ a ∈ s :=
  induction_on s fun _ => AList.lookup_isSome
#align finmap.lookup_is_some Finmap.lookup_isSome

theorem lookup_eq_none {a} {s : Finmap β} : lookup a s = none ↔ a ∉ s :=
  induction_on s fun _ => AList.lookup_eq_none
#align finmap.lookup_eq_none Finmap.lookup_eq_none

lemma mem_lookup_iff {s : Finmap β} {a : α} {b : β a} :
    b ∈ s.lookup a ↔ Sigma.mk a b ∈ s.entries := by
  rcases s with ⟨⟨l⟩, hl⟩; exact List.mem_dlookup_iff hl

lemma lookup_eq_some_iff {s : Finmap β} {a : α} {b : β a} :
    s.lookup a = b ↔ Sigma.mk a b ∈ s.entries := mem_lookup_iff

@[simp] lemma sigma_keys_lookup (s : Finmap β) :
    s.keys.sigma (fun i => (s.lookup i).toFinset) = ⟨s.entries, s.nodup_entries⟩ := by
  ext x
  have : x ∈ s.entries → x.1 ∈ s.keys := Multiset.mem_map_of_mem _
  simpa [lookup_eq_some_iff]

@[simp]
theorem lookup_singleton_eq {a : α} {b : β a} : (singleton a b).lookup a = some b := by
  rw [singleton, lookup_toFinmap, AList.singleton, AList.lookup, dlookup_cons_eq]
#align finmap.lookup_singleton_eq Finmap.lookup_singleton_eq

instance (a : α) (s : Finmap β) : Decidable (a ∈ s) :=
  decidable_of_iff _ lookup_isSome

theorem mem_iff {a : α} {s : Finmap β} : a ∈ s ↔ ∃ b, s.lookup a = some b :=
  induction_on s fun s =>
    Iff.trans List.mem_keys <| exists_congr fun _ => (mem_dlookup_iff s.nodupKeys).symm
#align finmap.mem_iff Finmap.mem_iff

theorem mem_of_lookup_eq_some {a : α} {b : β a} {s : Finmap β} (h : s.lookup a = some b) : a ∈ s :=
  mem_iff.mpr ⟨_, h⟩
#align finmap.mem_of_lookup_eq_some Finmap.mem_of_lookup_eq_some

theorem ext_lookup {s₁ s₂ : Finmap β} : (∀ x, s₁.lookup x = s₂.lookup x) → s₁ = s₂ :=
  induction_on₂ s₁ s₂ fun s₁ s₂ h => by
    simp only [AList.lookup, lookup_toFinmap] at h
    rw [AList.toFinmap_eq]
    apply lookup_ext s₁.nodupKeys s₂.nodupKeys
    intro x y
    rw [h]
#align finmap.ext_lookup Finmap.ext_lookup

/-- An equivalence between `Finmap β` and pairs `(keys : Finset α, lookup : ∀ a, Option (β a))` such
that `(lookup a).isSome ↔ a ∈ keys`. -/
@[simps apply_coe_fst apply_coe_snd]
def keysLookupEquiv :
    Finmap β ≃ { f : Finset α × (∀ a, Option (β a)) // ∀ i, (f.2 i).isSome ↔ i ∈ f.1 } where
  toFun s := ⟨(s.keys, fun i => s.lookup i), fun _ => lookup_isSome⟩
  invFun f := mk (f.1.1.sigma <| fun i => (f.1.2 i).toFinset).val <| by
    refine Multiset.nodup_keys.1 ((Finset.nodup _).map_on ?_)
    simp only [Finset.mem_val, Finset.mem_sigma, Option.mem_toFinset, Option.mem_def]
    rintro ⟨i, x⟩ ⟨_, hx⟩ ⟨j, y⟩ ⟨_, hy⟩ (rfl : i = j)
    simpa using hx.symm.trans hy
  left_inv f := ext <| by simp
  right_inv := fun ⟨(s, f), hf⟩ => by
    dsimp only at hf
    ext
    · simp [keys, Multiset.keys, ← hf, Option.isSome_iff_exists]
    · simp (config := { contextual := true }) [lookup_eq_some_iff, ← hf]

@[simp] lemma keysLookupEquiv_symm_apply_keys :
    ∀ f : {f : Finset α × (∀ a, Option (β a)) // ∀ i, (f.2 i).isSome ↔ i ∈ f.1},
      (keysLookupEquiv.symm f).keys = f.1.1 :=
  keysLookupEquiv.surjective.forall.2 $ fun _ => by
    simp only [Equiv.symm_apply_apply, keysLookupEquiv_apply_coe_fst]

@[simp] lemma keysLookupEquiv_symm_apply_lookup :
    ∀ (f : {f : Finset α × (∀ a, Option (β a)) // ∀ i, (f.2 i).isSome ↔ i ∈ f.1}) a,
      (keysLookupEquiv.symm f).lookup a = f.1.2 a :=
  keysLookupEquiv.surjective.forall.2 $ fun _ _ => by
    simp only [Equiv.symm_apply_apply, keysLookupEquiv_apply_coe_snd]

/-! ### replace -/

/-- Replace a key with a given value in a finite map.
  If the key is not present it does nothing. -/
def replace (a : α) (b : β a) (s : Finmap β) : Finmap β :=
  (liftOn s fun t => AList.toFinmap (AList.replace a b t))
    fun _ _ p => toFinmap_eq.2 <| perm_replace p
#align finmap.replace Finmap.replace

-- Porting note: explicit type required because of the ambiguity
@[simp]
theorem replace_toFinmap (a : α) (b : β a) (s : AList β) :
    replace a b ⟦s⟧ = (⟦s.replace a b⟧ : Finmap β) := by
  simp [replace]
#align finmap.replace_to_finmap Finmap.replace_toFinmap

@[simp]
theorem keys_replace (a : α) (b : β a) (s : Finmap β) : (replace a b s).keys = s.keys :=
  induction_on s fun s => by simp
#align finmap.keys_replace Finmap.keys_replace

@[simp]
theorem mem_replace {a a' : α} {b : β a} {s : Finmap β} : a' ∈ replace a b s ↔ a' ∈ s :=
  induction_on s fun s => by simp
#align finmap.mem_replace Finmap.mem_replace

end

/-! ### foldl -/

/-- Fold a commutative function over the key-value pairs in the map -/
def foldl {δ : Type w} (f : δ → ∀ a, β a → δ)
    (H : ∀ d a₁ b₁ a₂ b₂, f (f d a₁ b₁) a₂ b₂ = f (f d a₂ b₂) a₁ b₁) (d : δ) (m : Finmap β) : δ :=
  m.entries.foldl (fun d s => f d s.1 s.2) (fun _ _ _ => H _ _ _ _ _) d
#align finmap.foldl Finmap.foldl

/-- `any f s` returns `true` iff there exists a value `v` in `s` such that `f v = true`. -/
def any (f : ∀ x, β x → Bool) (s : Finmap β) : Bool :=
  s.foldl (fun x y z => x || f y z)
    (fun _ _ _ _ => by simp_rw [Bool.or_assoc, Bool.or_comm, imp_true_iff]) false
#align finmap.any Finmap.any

-- TODO: should this really return `false` if `s` is empty?
/-- `all f s` returns `true` iff `f v = true` for all values `v` in `s`. -/
def all (f : ∀ x, β x → Bool) (s : Finmap β) : Bool :=
  s.foldl (fun x y z => x && f y z)
    (fun _ _ _ _ => by simp_rw [Bool.and_assoc, Bool.and_comm, imp_true_iff]) true
#align finmap.all Finmap.all

/-! ### erase -/

section

variable [DecidableEq α]

/-- Erase a key from the map. If the key is not present it does nothing. -/
def erase (a : α) (s : Finmap β) : Finmap β :=
  (liftOn s fun t => AList.toFinmap (AList.erase a t)) fun _ _ p => toFinmap_eq.2 <| perm_erase p
#align finmap.erase Finmap.erase

@[simp]
theorem erase_toFinmap (a : α) (s : AList β) : erase a ⟦s⟧ = AList.toFinmap (s.erase a) := by
  simp [erase]
#align finmap.erase_to_finmap Finmap.erase_toFinmap

@[simp]
theorem keys_erase_toFinset (a : α) (s : AList β) : keys ⟦s.erase a⟧ = (keys ⟦s⟧).erase a := by
  simp [Finset.erase, keys, AList.erase, keys_kerase]
#align finmap.keys_erase_to_finset Finmap.keys_erase_toFinset

@[simp]
theorem keys_erase (a : α) (s : Finmap β) : (erase a s).keys = s.keys.erase a :=
  induction_on s fun s => by simp
#align finmap.keys_erase Finmap.keys_erase

@[simp]
theorem mem_erase {a a' : α} {s : Finmap β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
  induction_on s fun s => by simp
#align finmap.mem_erase Finmap.mem_erase

theorem not_mem_erase_self {a : α} {s : Finmap β} : ¬a ∈ erase a s := by
  rw [mem_erase, not_and_or, not_not]
  left
  rfl
#align finmap.not_mem_erase_self Finmap.not_mem_erase_self

@[simp]
theorem lookup_erase (a) (s : Finmap β) : lookup a (erase a s) = none :=
  induction_on s <| AList.lookup_erase a
#align finmap.lookup_erase Finmap.lookup_erase

@[simp]
theorem lookup_erase_ne {a a'} {s : Finmap β} (h : a ≠ a') : lookup a (erase a' s) = lookup a s :=
  induction_on s fun _ => AList.lookup_erase_ne h
#align finmap.lookup_erase_ne Finmap.lookup_erase_ne

theorem erase_erase {a a' : α} {s : Finmap β} : erase a (erase a' s) = erase a' (erase a s) :=
  induction_on s fun s => ext (by simp only [AList.erase_erase, erase_toFinmap])
#align finmap.erase_erase Finmap.erase_erase

/-! ### sdiff -/

/-- `sdiff s s'` consists of all key-value pairs from `s` and `s'` where the keys are in `s` or
`s'` but not both. -/
def sdiff (s s' : Finmap β) : Finmap β :=
  s'.foldl (fun s x _ => s.erase x) (fun _ _ _ _ _ => erase_erase) s
#align finmap.sdiff Finmap.sdiff

instance : SDiff (Finmap β) :=
  ⟨sdiff⟩

/-! ### insert -/

/-- Insert a key-value pair into a finite map, replacing any existing pair with
  the same key. -/
def insert (a : α) (b : β a) (s : Finmap β) : Finmap β :=
  (liftOn s fun t => AList.toFinmap (AList.insert a b t)) fun _ _ p =>
    toFinmap_eq.2 <| perm_insert p
#align finmap.insert Finmap.insert

@[simp]
theorem insert_toFinmap (a : α) (b : β a) (s : AList β)
  : insert a b (AList.toFinmap s) = AList.toFinmap (s.insert a b) := by
  simp [insert]
#align finmap.insert_to_finmap Finmap.insert_toFinmap

theorem insert_entries_of_neg {a : α} {b : β a} {s : Finmap β} :
    a ∉ s → (insert a b s).entries = ⟨a, b⟩ ::ₘ s.entries :=
  induction_on s fun s h => by
    -- Porting note: `-insert_entries` required
    simp [AList.insert_entries_of_neg (mt mem_toFinmap.1 h), -insert_entries]
#align finmap.insert_entries_of_neg Finmap.insert_entries_of_neg

@[simp]
theorem mem_insert {a a' : α} {b' : β a'} {s : Finmap β} : a ∈ insert a' b' s ↔ a = a' ∨ a ∈ s :=
  induction_on s AList.mem_insert
#align finmap.mem_insert Finmap.mem_insert

@[simp]
theorem lookup_insert {a} {b : β a} (s : Finmap β) : lookup a (insert a b s) = some b :=
  induction_on s fun s => by simp only [insert_toFinmap, lookup_toFinmap, AList.lookup_insert]
#align finmap.lookup_insert Finmap.lookup_insert

@[simp]
theorem lookup_insert_of_ne {a a'} {b : β a} (s : Finmap β) (h : a' ≠ a) :
    lookup a' (insert a b s) = lookup a' s :=
  induction_on s fun s => by simp only [insert_toFinmap, lookup_toFinmap, lookup_insert_ne h]
#align finmap.lookup_insert_of_ne Finmap.lookup_insert_of_ne

@[simp]
theorem insert_insert {a} {b b' : β a} (s : Finmap β) :
    (s.insert a b).insert a b' = s.insert a b' :=
  induction_on s fun s => by simp only [insert_toFinmap, AList.insert_insert]
#align finmap.insert_insert Finmap.insert_insert

theorem insert_insert_of_ne {a a'} {b : β a} {b' : β a'} (s : Finmap β) (h : a ≠ a') :
    (s.insert a b).insert a' b' = (s.insert a' b').insert a b :=
  induction_on s fun s => by
    simp only [insert_toFinmap, AList.toFinmap_eq, AList.insert_insert_of_ne _ h]
#align finmap.insert_insert_of_ne Finmap.insert_insert_of_ne

theorem toFinmap_cons (a : α) (b : β a) (xs : List (Sigma β)) :
    List.toFinmap (⟨a, b⟩ :: xs) = insert a b xs.toFinmap :=
  rfl
#align finmap.to_finmap_cons Finmap.toFinmap_cons

theorem mem_list_toFinmap (a : α) (xs : List (Sigma β)) :
    a ∈ xs.toFinmap ↔ ∃ b : β a, Sigma.mk a b ∈ xs := by
  induction' xs with x xs <;> [skip, cases' x with fst_i snd_i] <;>
      -- Porting note: `Sigma.mk.inj_iff` required because `simp` behaves differently
      simp only [toFinmap_cons, *, not_mem_empty, exists_or, not_mem_nil, toFinmap_nil,
        exists_false, mem_cons, mem_insert, exists_and_left, Sigma.mk.inj_iff];
      apply or_congr _ Iff.rfl
  conv =>
    lhs
    rw [← and_true_iff (a = fst_i)]
  apply and_congr_right
  rintro ⟨⟩
  simp only [exists_eq, heq_iff_eq]
#align finmap.mem_list_to_finmap Finmap.mem_list_toFinmap

@[simp]
theorem insert_singleton_eq {a : α} {b b' : β a} : insert a b (singleton a b') = singleton a b := by
  simp only [singleton, Finmap.insert_toFinmap, AList.insert_singleton_eq]
#align finmap.insert_singleton_eq Finmap.insert_singleton_eq

/-! ### extract -/

/-- Erase a key from the map, and return the corresponding value, if found. -/
def extract (a : α) (s : Finmap β) : Option (β a) × Finmap β :=
  (liftOn s fun t => Prod.map id AList.toFinmap (AList.extract a t)) fun s₁ s₂ p => by
    simp [perm_lookup p, toFinmap_eq, perm_erase p]
#align finmap.extract Finmap.extract

@[simp]
theorem extract_eq_lookup_erase (a : α) (s : Finmap β) : extract a s = (lookup a s, erase a s) :=
  induction_on s fun s => by simp [extract]
#align finmap.extract_eq_lookup_erase Finmap.extract_eq_lookup_erase

/-! ### union -/

/-- `s₁ ∪ s₂` is the key-based union of two finite maps. It is left-biased: if
there exists an `a ∈ s₁`, `lookup a (s₁ ∪ s₂) = lookup a s₁`. -/
def union (s₁ s₂ : Finmap β) : Finmap β :=
  (liftOn₂ s₁ s₂ fun s₁ s₂ => (AList.toFinmap (s₁ ∪ s₂))) fun _ _ _ _ p₁₃ p₂₄ =>
    toFinmap_eq.mpr <| perm_union p₁₃ p₂₄
#align finmap.union Finmap.union

instance : Union (Finmap β) :=
  ⟨union⟩

@[simp]
theorem mem_union {a} {s₁ s₂ : Finmap β} : a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
  induction_on₂ s₁ s₂ fun _ _ => AList.mem_union
#align finmap.mem_union Finmap.mem_union

@[simp]
theorem union_toFinmap (s₁ s₂ : AList β)
  : (toFinmap s₁) ∪ (toFinmap s₂) = toFinmap (s₁ ∪ s₂) := by simp [(· ∪ ·), union]
#align finmap.union_to_finmap Finmap.union_toFinmap

theorem keys_union {s₁ s₂ : Finmap β} : (s₁ ∪ s₂).keys = s₁.keys ∪ s₂.keys :=
  induction_on₂ s₁ s₂ fun s₁ s₂ => Finset.ext <| by simp [keys]
#align finmap.keys_union Finmap.keys_union

@[simp]
theorem lookup_union_left {a} {s₁ s₂ : Finmap β} : a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
  induction_on₂ s₁ s₂ fun _ _ => AList.lookup_union_left
#align finmap.lookup_union_left Finmap.lookup_union_left

@[simp]
theorem lookup_union_right {a} {s₁ s₂ : Finmap β} : a ∉ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₂ :=
  induction_on₂ s₁ s₂ fun _ _ => AList.lookup_union_right
#align finmap.lookup_union_right Finmap.lookup_union_right

theorem lookup_union_left_of_not_in {a} {s₁ s₂ : Finmap β} (h : a ∉ s₂) :
    lookup a (s₁ ∪ s₂) = lookup a s₁ := by
  by_cases h' : a ∈ s₁
  · rw [lookup_union_left h']
  · rw [lookup_union_right h', lookup_eq_none.mpr h, lookup_eq_none.mpr h']
#align finmap.lookup_union_left_of_not_in Finmap.lookup_union_left_of_not_in

-- @[simp] -- Porting note: simp can prove this
theorem mem_lookup_union {a} {b : β a} {s₁ s₂ : Finmap β} :
    b ∈ lookup a (s₁ ∪ s₂) ↔ b ∈ lookup a s₁ ∨ a ∉ s₁ ∧ b ∈ lookup a s₂ :=
  induction_on₂ s₁ s₂ fun _ _ => AList.mem_lookup_union
#align finmap.mem_lookup_union Finmap.mem_lookup_union

theorem mem_lookup_union_middle {a} {b : β a} {s₁ s₂ s₃ : Finmap β} :
    b ∈ lookup a (s₁ ∪ s₃) → a ∉ s₂ → b ∈ lookup a (s₁ ∪ s₂ ∪ s₃) :=
  induction_on₃ s₁ s₂ s₃ fun _ _ _ => AList.mem_lookup_union_middle
#align finmap.mem_lookup_union_middle Finmap.mem_lookup_union_middle

theorem insert_union {a} {b : β a} {s₁ s₂ : Finmap β} : insert a b (s₁ ∪ s₂) = insert a b s₁ ∪ s₂ :=
  induction_on₂ s₁ s₂ fun a₁ a₂ => by simp [AList.insert_union]
#align finmap.insert_union Finmap.insert_union

theorem union_assoc {s₁ s₂ s₃ : Finmap β} : s₁ ∪ s₂ ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) :=
  induction_on₃ s₁ s₂ s₃ fun s₁ s₂ s₃ => by
    simp only [AList.toFinmap_eq, union_toFinmap, AList.union_assoc]
#align finmap.union_assoc Finmap.union_assoc

@[simp]
theorem empty_union {s₁ : Finmap β} : ∅ ∪ s₁ = s₁ :=
  induction_on s₁ fun s₁ => by
    rw [← empty_toFinmap]
    simp [-empty_toFinmap, AList.toFinmap_eq, union_toFinmap, AList.union_assoc]
#align finmap.empty_union Finmap.empty_union

@[simp]
theorem union_empty {s₁ : Finmap β} : s₁ ∪ ∅ = s₁ :=
  induction_on s₁ fun s₁ => by
    rw [← empty_toFinmap]
    simp [-empty_toFinmap, AList.toFinmap_eq, union_toFinmap, AList.union_assoc]
#align finmap.union_empty Finmap.union_empty

theorem erase_union_singleton (a : α) (b : β a) (s : Finmap β) (h : s.lookup a = some b) :
    s.erase a ∪ singleton a b = s :=
  ext_lookup fun x => by
    by_cases h' : x = a
    · subst a
      rw [lookup_union_right not_mem_erase_self, lookup_singleton_eq, h]
    · have : x ∉ singleton a b := by rwa [mem_singleton]
      rw [lookup_union_left_of_not_in this, lookup_erase_ne h']
#align finmap.erase_union_singleton Finmap.erase_union_singleton

end

/-! ### Disjoint -/

/-- `Disjoint s₁ s₂` holds if `s₁` and `s₂` have no keys in common. -/
def Disjoint (s₁ s₂ : Finmap β) : Prop :=
  ∀ x ∈ s₁, ¬x ∈ s₂
#align finmap.disjoint Finmap.Disjoint

theorem disjoint_empty (x : Finmap β) : Disjoint ∅ x :=
  fun.
#align finmap.disjoint_empty Finmap.disjoint_empty

@[symm]
theorem Disjoint.symm (x y : Finmap β) (h : Disjoint x y) : Disjoint y x := fun p hy hx => h p hx hy
#align finmap.disjoint.symm Finmap.Disjoint.symm

theorem Disjoint.symm_iff (x y : Finmap β) : Disjoint x y ↔ Disjoint y x :=
  ⟨Disjoint.symm x y, Disjoint.symm y x⟩
#align finmap.disjoint.symm_iff Finmap.Disjoint.symm_iff

section

variable [DecidableEq α]

instance : DecidableRel (@Disjoint α β) := fun x y => by dsimp only [Disjoint]; infer_instance

theorem disjoint_union_left (x y z : Finmap β) : Disjoint (x ∪ y) z ↔ Disjoint x z ∧ Disjoint y z :=
  by simp [Disjoint, Finmap.mem_union, or_imp, forall_and]
#align finmap.disjoint_union_left Finmap.disjoint_union_left

theorem disjoint_union_right (x y z : Finmap β) :
    Disjoint x (y ∪ z) ↔ Disjoint x y ∧ Disjoint x z := by
  rw [Disjoint.symm_iff, disjoint_union_left, Disjoint.symm_iff _ x, Disjoint.symm_iff _ x]
#align finmap.disjoint_union_right Finmap.disjoint_union_right

theorem union_comm_of_disjoint {s₁ s₂ : Finmap β} : Disjoint s₁ s₂ → s₁ ∪ s₂ = s₂ ∪ s₁ :=
  induction_on₂ s₁ s₂ fun s₁ s₂ => by
    intro h
    simp only [AList.toFinmap_eq, union_toFinmap, AList.union_comm_of_disjoint h]
#align finmap.union_comm_of_disjoint Finmap.union_comm_of_disjoint

theorem union_cancel {s₁ s₂ s₃ : Finmap β} (h : Disjoint s₁ s₃) (h' : Disjoint s₂ s₃) :
    s₁ ∪ s₃ = s₂ ∪ s₃ ↔ s₁ = s₂ :=
  ⟨fun h'' => by
    apply ext_lookup
    intro x
    have : (s₁ ∪ s₃).lookup x = (s₂ ∪ s₃).lookup x := h'' ▸ rfl
    by_cases hs₁ : x ∈ s₁
    · rwa [lookup_union_left hs₁, lookup_union_left_of_not_in (h _ hs₁)] at this
    · by_cases hs₂ : x ∈ s₂
      · rwa [lookup_union_left_of_not_in (h' _ hs₂), lookup_union_left hs₂] at this
      · rw [lookup_eq_none.mpr hs₁, lookup_eq_none.mpr hs₂], fun h => h ▸ rfl⟩
#align finmap.union_cancel Finmap.union_cancel

end

end Finmap