import data.multiset data.equiv.basic data.nat.basic group_theory.perm

open equiv.perm equiv list

variables {α : Type*} {β : Type*} [decidable_eq α]

def thing : list α → list (perm α)
| []       := [1]
| (a :: l) := thing l ++ l.bind (λ b, (thing l).map (λ f, swap a b * f))

@[simp] lemma thing_nil : thing ([] : list α) = [1] := rfl

lemma length_thing : ∀ l : list α, length (thing l) = l.length.fact
| []       := rfl
| (a :: l) := by rw [length_cons, nat.fact_succ];
  simp [thing, length_bind, length_thing, function.comp, nat.succ_mul]

lemma mem_thing : ∀ (l : list α) (f : perm α) (hl : l.nodup) (h : ∀ x, f x ≠ x → x ∈ l), f ∈ thing l
| []     f hl h := list.mem_singleton.2 $ equiv.ext _ _$ λ x, by simp [imp_false, *] at *
| (a::l) f hl h :=
if hfa : f a = a
then
  mem_append_left _ $ mem_thing _ _ (list.nodup_of_nodup_cons hl)
    (λ x hx, mem_of_ne_of_mem (λ h, by rw h at hx; exact hx hfa) (h x hx))
else
have hfa' : f (f a) ≠ f a, from mt (λ h, f.bijective.1 h) hfa,
have ∀ (x : α), (swap a (f a) * f) x ≠ x → x ∈ l,
  from λ x hx, have hxa : x ≠ a, from λ h, by simpa [h, mul_apply] using hx,
    have hfxa : f x ≠ f a, from mt (λ h, f.bijective.1 h) hxa,
    list.mem_of_ne_of_mem hxa
      (h x (λ h, by simp [h, mul_apply, swap_apply_def] at hx; split_ifs at hx; cc)),
suffices f ∈ thing l ∨ ∃ (b : α), b ∈ l ∧ ∃ g : perm α, g ∈ thing l ∧ swap a b * g = f,
  by simpa [thing],
(@or_iff_not_imp_left _ _ (classical.prop_decidable _)).2
  (λ hfl, ⟨f a,
    if hffa : f (f a) = a then mem_of_ne_of_mem hfa (h _ (mt (λ h, f.bijective.1 h) hfa))
      else this _ $ by simp [mul_apply, swap_apply_def]; split_ifs; cc,
    ⟨swap a (f a) * f, mem_thing _ _ (list.nodup_of_nodup_cons hl) this,
      by rw [← mul_assoc, mul_def (swap a (f a)) (swap a (f a)), swap_swap, ← one_def, one_mul]⟩⟩)

lemma mem_thing' : ∀ (l : list α) (f : perm α), f ∈ thing l → ∀ x, f x ≠ x → x ∈ l
| []     f h := have f = 1 := by simpa [thing] using h, by rw this; simp
| (a::l) f h :=
(mem_append.1 h).elim
  (λ h x hx, mem_cons_of_mem _ (mem_thing' l f h x hx))
  (λ h x hx,
    let ⟨y, hy, hy'⟩ := mem_bind.1 h in
    let ⟨g, hg₁, hg₂⟩ := mem_map.1 hy' in
    if hxa : x = a then by simp [hxa]
    else if hxy : x = y then mem_cons_of_mem _ $ by rwa hxy
    else mem_cons_of_mem _ $
    mem_thing' l g hg₁ _ $
      by rw [eq_inv_mul_iff_mul_eq.2 hg₂, mul_apply, swap_inv, swap_apply_def];
        split_ifs; cc)

lemma nodup_thing : ∀ (l : list α) (hl : l.nodup), (thing l).nodup
| []     hl := by simp [thing]
| (a::l) hl :=
have hl' : l.nodup, from nodup_of_nodup_cons hl,
have hln' : (thing l).nodup, from nodup_thing _ hl',
have hmeml : ∀ {f : perm α}, f ∈ thing l → f a = a,
  from λ f hf, not_not.1 (mt (mem_thing' l f hf a) (nodup_cons.1 hl).1),
by rw [thing, list.nodup_append, list.nodup_bind, pairwise_iff_nth_le]; exact
⟨hln', ⟨λ _ _, nodup_map (λ _ _, (mul_left_inj _).1) hln',
  λ i j hj hij x hx₁ hx₂,
    let ⟨f, hf⟩ := mem_map.1 hx₁ in
    let ⟨g, hg⟩ := mem_map.1 hx₂ in
    have hix : x a = nth_le l i (lt_trans hij hj),
      by rw [← hf.2, mul_apply, hmeml hf.1, swap_apply_left],
    have hiy : x a = nth_le l j hj,
      by rw [← hg.2, mul_apply, hmeml hg.1, swap_apply_left],
    absurd (hf.2.trans (hg.2.symm)) $
      λ h, ne_of_lt hij $ nodup_iff_nth_le_inj.1 hl' i j (lt_trans hij hj) hj $
        by rw [← hix, hiy]⟩,
  λ f hf₁ hf₂,
    let ⟨x, hx, hx'⟩ := mem_bind.1 hf₂ in
    let ⟨g, hg⟩ := mem_map.1 hx' in
    have hgxa : g⁻¹ x = a, from f.bijective.1 $
      by rw [hmeml hf₁, ← hg.2]; simp,
    have hxa : x ≠ a, from λ h, (list.nodup_cons.1 hl).1 (h ▸ hx),
    (list.nodup_cons.1 hl).1 $
      hgxa ▸ mem_thing' _ _ hg.1 _ (by rwa [apply_inv_self, hgxa])⟩

def perm_fintype_aux [decidable_eq (perm α)] {s : multiset α} :
  (∀ x, x ∈ s) → s.nodup → fintype (perm α) :=
quotient.rec_on_subsingleton s (λ l hl hln, ⟨⟨thing l, nodup_thing _ hln⟩,
  (λ x, mem_thing _ _ hln (λ _ _, (hl _)))⟩)

instance perm.fintype [fintype α] : fintype (perm α) := perm_fintype_aux finset.mem_univ finset.univ.2

lemma card_perm [fintype α] : fintype.card (perm α) = (fintype.card α).fact :=
quotient.induction_on (@finset.univ α _).1 begin end

#exit

lemma thing_cons (m : multiset α) (a : α) :
  thing (a :: m) = thing m + m.bind (λ b, (thing m).map (λ f, swap a b * f)) :=
by simp [thing]

lemma mem_perm (m : multiset α) (f : perm α) : (∀ x, f x ≠ x → x ∈ m) → f ∈ thing m :=
multiset.induction_on m
  (λ h, mem_singleton.2 $ equiv.ext _ _ $ λ x, not_not.1 $ by simpa [-not_not, not_mem_zero] using h x)
  $ λ a s ih h, begin
    simp [thing_cons],

  end

lemma card_perm (m : multiset α) : (thing m).card = nat.fact m.card :=
multiset.induction_on m rfl (λ a s ih, by rw [card_cons, nat.fact_succ];
  simp [thing_cons, card_add, ih, card_bind, mul_comm, nat.mul_succ])

def perm.cons (e : α ≃ β) (m : multiset α) (a : α) (b : β) (f : α ≃ β) : α ≃ β :=
(swap a (e.symm b)).trans f

def list_to_function : Π (l₁ : list α) (l₂ : list β), l₁.length = l₂.length → Π a ∈ l₁, β
| []      l₂      h₁ a h₂ := absurd h₂ (list.not_mem_nil _)
| (b::l₁) []      h₁ a h₂ := absurd h₁ (nat.succ_ne_zero _)
| (b::l₁) (c::l₂) h₁ a h₂ := if h : a = b then c
  else list_to_function l₁ l₂ (nat.succ_inj h₁) a (list.mem_of_ne_of_mem h h₂)

open list nat

def list_to_perm : Π (l₁ : list α) (l₂ : list β), l₁.length = l₂.length →
  {a // a ∈ l₁} ≃ {b // b ∈ l₂}
| []      []      h := ⟨λ a, (not_mem_nil _ a.2).elim, λ b, (not_mem_nil _ b.2).elim,
  λ a, (not_mem_nil _ a.2).elim, λ b, (not_mem_nil _ b.2).elim⟩
| []      (b::l₂) h := (succ_ne_zero _ h.symm).elim
| (a::l₁) []      h := (succ_ne_zero _ h).elim
| (a::l₁) (b::l₂) h :=
let f := list_to_perm l₁ l₂ (succ_inj h) in
{ to_fun := λ x, if h : x.1 = a then ⟨b, list.mem_cons_self _ _⟩
            else ⟨(f ⟨x, mem_of_ne_of_mem h x.2⟩).1, mem_cons_of_mem _ begin end⟩  }

def multiset.perm (m : multiset α) (t : multiset β) : multiset (α ≃ β) :=
multiset.rec_on m (e :: 0)
  (λ a m ih, m.bind (λ b, ih.map (λ f, begin end)))
  (λ x y s t, heq_of_eq begin
    simp [multiset.map_bind, bind_bind, swap_comm],
    rw [bind_map_comm],

  end)


import deduction.deduction_monadic data.set.basic
open deduction_basic

namespace MPPC_defn

    inductive MPPC_Form : Type
    | top : MPPC_Form
    | var : ℕ → MPPC_Form
    | and : MPPC_Form → MPPC_Form → MPPC_Form
    | impl : MPPC_Form → MPPC_Form → MPPC_Form
    | diamond : MPPC_Form → MPPC_Form

    @[reducible] def MPPC_Hyp : Type := set (MPPC_Form)

    instance : has_union MPPC_Hyp := infer_instance
    instance : has_mem MPPC_Form MPPC_Hyp := infer_instance
    instance : has_insert MPPC_Form MPPC_Hyp := infer_instance
    instance : has_emptyc MPPC_Hyp := infer_instance

    inductive isModal : MPPC_Hyp → Prop
    | ModalEmpty : isModal ∅
    | ModalInsert : ∀ (Φ : MPPC_Hyp) (φ : MPPC_Form),
        isModal Φ → isModal (insert (MPPC_Form.diamond φ) Φ)

    inductive MPPC_derives : MPPC_Hyp → MPPC_Form → Prop
    | hyp {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : (φ ∈ Φ) →  MPPC_derives Φ φ
    | truth {Φ}
        : MPPC_derives Φ MPPC_Form.top
    | and_intro {Φ} {φ ψ : MPPC_Form}
        : MPPC_derives Φ φ → MPPC_derives Φ ψ → MPPC_derives Φ (MPPC_Form.and φ ψ)
    | and_eliml {Φ} {φ ψ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.and φ ψ) → MPPC_derives Φ φ
    | and_elimr {Φ} {φ ψ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.and φ ψ) → MPPC_derives Φ ψ
    | impl_intro {Φ : MPPC_Hyp} (φ : MPPC_Form) {ψ : MPPC_Form}
        : MPPC_derives (insert φ Φ) ψ → MPPC_derives Φ (MPPC_Form.impl φ ψ)
    | impl_elim {Φ : MPPC_Hyp} (φ : MPPC_Form) {ψ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.impl φ ψ) → MPPC_derives Φ φ → MPPC_derives Φ ψ
    | weak {Φ Ψ : MPPC_Hyp} {φ : MPPC_Form}
        : MPPC_derives Φ φ → MPPC_derives (Φ ∪ Ψ) φ
    | dmap {Φ : MPPC_Hyp}{φ ψ : MPPC_Form}
        : MPPC_derives (insert φ Φ) ψ → MPPC_derives (insert (MPPC_Form.diamond φ) Φ) (MPPC_Form.diamond ψ)
    | dpure {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : MPPC_derives Φ φ → MPPC_derives Φ (MPPC_Form.diamond φ)
    | djoin {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : MPPC_derives Φ (MPPC_Form.diamond(MPPC_Form.diamond φ)) → MPPC_derives Φ (MPPC_Form.diamond φ)
    open MPPC_derives

notation (name:= MPPC.diamond) `◇`:81 φ := MPPC_Form.diamond φ

end MPPC_defn

namespace MPPC_has_derives

    open MPPC_defn
    open MPPC_defn.MPPC_derives
    open deduction_basic
    open deduction_cart
    open deduction_monadic
    open MPPC_defn.MPPC_Form

    instance MPPC_hasHyp : has_Hyp MPPC_Form :=
      { Hyp := MPPC_Hyp }

    instance MPPC_singleton : has_singleton MPPC_Form MPPC_Hyp :=
      deduction_basic.singleHyp
    @[simp]
    lemma same_singles : ∀ φ : MPPC_Form,
        MPPC_has_derives.MPPC_singleton.singleton φ = set.has_singleton.singleton φ :=
    begin
      assume φ,
      dsimp[MPPC_has_derives.MPPC_singleton,deduction_basic.singleHyp],
      rw set.is_lawful_singleton.insert_emptyc_eq,
    end

    lemma single_union {Φ : MPPC_Hyp} {φ : MPPC_Form}
        : insert φ Φ = {φ} ∪ Φ := by simp

    instance MPPC_Der : has_struct_derives MPPC_Form :=
    {
      derives := MPPC_derives,
      derive_Trans :=
        begin
          assume Φ ψ θ hφψ hψθ,
          have helper : MPPC_derives Φ (MPPC_Form.impl ψ θ),
            apply impl_intro,
            rw single_union,
            apply weak,
            exact hψθ,
          apply impl_elim ψ,
          exact helper,
          exact hφψ,
        end,
      inInsert := set.mem_insert,
      hyp := @hyp,
      weak1 :=
        begin
          assume Φ φ ψ h,
          rw single_union,
          rw set.union_comm,
          apply weak,
          exact h,
        end,
    }

    instance MPPC_top : deduction_cart.has_ltop MPPC_Form :=
    {
      top := MPPC_Form.top,
      truth := @truth,
    }
    instance MPPC_and : deduction_cart.has_and MPPC_Form :=
    {
      and := MPPC_Form.and,
      and_intro := @and_intro,
      and_eliml := @and_eliml,
      and_elimr := @and_elimr,
    }
    instance MPPC_impl : deduction_cart.has_impl MPPC_Form :=
    {
      impl := MPPC_Form.impl,
      impl_intro := @impl_intro,
      impl_elim := @impl_elim,
    }
    instance MPPC_diamond : deduction_monadic.has_diamond MPPC_Form :=
    {
      diamond := MPPC_Form.diamond,
      dmap := @dmap,
      dpure := @dpure,
      djoin := @djoin,
    }

end MPPC_has_derives


/-
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
-/
import data.list.alist
import data.finset.basic
import data.part
/-!
# Finite maps over `multiset`
-/

universes u v w
open list
variables {α : 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

@[simp] theorem coe_keys {l : list (sigma β)} :
  keys (l : multiset (sigma β)) = (l.keys : multiset α) :=
rfl

/-- `nodupkeys s` means that `s` has no duplicate keys. -/
def nodupkeys (s : multiset (sigma β)) : Prop :=
quot.lift_on s list.nodupkeys (λ s t p, propext $ perm_nodupkeys p)

@[simp] theorem coe_nodupkeys {l : list (sigma β)} : @nodupkeys α β l ↔ l.nodupkeys := iff.rfl

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) :=
(entries : multiset (sigma β))
(nodupkeys : entries.nodupkeys)

/-- The quotient map from `alist` to `finmap`. -/
def alist.to_finmap (s : alist β) : finmap β := ⟨s.entries, s.nodupkeys⟩

local notation `⟦`:max a `⟧`:0 := alist.to_finmap a

theorem alist.to_finmap_eq {s₁ s₂ : alist β} :
  ⟦s₁⟧ = ⟦s₂⟧ ↔ s₁.entries ~ s₂.entries :=
by cases s₁; cases s₂; simp [alist.to_finmap]

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

/-- Given `l : list (sigma β)`, create a term of type `finmap β` by removing
entries with duplicate keys. -/
def list.to_finmap [decidable_eq α] (s : list (sigma β)) : finmap β := s.to_alist.to_finmap

namespace finmap
open alist

/-! ### lifting from alist -/

/-- Lift a permutation-respecting function on `alist` to `finmap`. -/
@[elab_as_eliminator] def lift_on
  {γ} (s : finmap β) (f : alist β → γ)
  (H : ∀ a b : alist β, a.entries ~ b.entries → f a = f b) : γ :=
begin
  refine (quotient.lift_on s.1 (λ l, (⟨_, λ nd, f ⟨l, nd⟩⟩ : part γ))
    (λ l₁ l₂ p, part.ext' (perm_nodupkeys p) _) : part γ).get _,
  { exact λ h₁ h₂, H _ _ (by exact p) },
  { have := s.nodupkeys, rcases s.entries with ⟨l⟩, exact id }
end

@[simp] theorem lift_on_to_finmap {γ} (s : alist β) (f : alist β → γ) (H) :
  lift_on ⟦s⟧ f H = f s := by cases s; refl

/-- Lift a permutation-respecting function on 2 `alist`s to 2 `finmap`s. -/
@[elab_as_eliminator] def lift_on₂
  {γ} (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₂) : γ :=
lift_on s₁
  (λ l₁, lift_on s₂ (f l₁) (λ b₁ b₂ p, H _ _ _ _ (perm.refl _) p))
  (λ a₁ a₂ p, have H' : f a₁ = f a₂ := funext (λ _, H _ _ _ _ p (perm.refl _)), by simp only [H'])

@[simp] theorem lift_on₂_to_finmap {γ} (s₁ s₂ : alist β) (f : alist β → alist β → γ) (H) :
  lift_on₂ ⟦s₁⟧ ⟦s₂⟧ f H = f s₁ s₂ :=
by cases s₁; cases s₂; refl

/-! ### induction -/

@[elab_as_eliminator] 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⟩

@[elab_as_eliminator] theorem induction_on₂ {C : finmap β → finmap β → Prop}
  (s₁ s₂ : finmap β) (H : ∀ (a₁ a₂ : alist β), C ⟦a₁⟧ ⟦a₂⟧) : C s₁ s₂ :=
induction_on s₁ $ λ l₁, induction_on s₂ $ λ l₂, H l₁ l₂

@[elab_as_eliminator] 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₂ $ λ l₁ l₂, induction_on s₃ $ λ l₃, H l₁ l₂ l₃

/-! ### extensionality -/

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

@[simp] theorem ext_iff {s t : finmap β} : s.entries = t.entries ↔ s = t :=
⟨ext, congr_arg _⟩

/-! ### mem -/

/-- The predicate `a ∈ s` means that `s` has a value associated to the key `a`. -/
instance : has_mem α (finmap β) := ⟨λ a s, a ∈ s.entries.keys⟩

theorem mem_def {a : α} {s : finmap β} :
  a ∈ s ↔ a ∈ s.entries.keys := iff.rfl

@[simp] theorem mem_to_finmap {a : α} {s : alist β} :
  a ∈ ⟦s⟧ ↔ a ∈ s := iff.rfl

/-! ### keys -/

/-- The set of keys of a finite map. -/
def keys (s : finmap β) : finset α :=
⟨s.entries.keys, induction_on s keys_nodup⟩

@[simp] theorem keys_val (s : alist β) : (keys ⟦s⟧).val = s.keys := rfl

@[simp] theorem keys_ext {s₁ s₂ : alist β} :
  keys ⟦s₁⟧ = keys ⟦s₂⟧ ↔ s₁.keys ~ s₂.keys :=
by simp [keys, alist.keys]

theorem mem_keys {a : α} {s : finmap β} : a ∈ s.keys ↔ a ∈ s :=
induction_on s $ λ s, alist.mem_keys

/-! ### empty -/

/-- The empty map. -/
instance : has_emptyc (finmap β) := ⟨⟨0, nodupkeys_nil⟩⟩

instance : inhabited (finmap β) := ⟨∅⟩

@[simp] theorem empty_to_finmap : (⟦∅⟧ : finmap β) = ∅ := rfl

@[simp] theorem to_finmap_nil [decidable_eq α] : ([].to_finmap : finmap β) = ∅ := rfl

theorem not_mem_empty {a : α} : a ∉ (∅ : finmap β) :=
multiset.not_mem_zero a

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

/-! ### singleton -/

/-- The singleton map. -/
def singleton (a : α) (b : β a) : finmap β := ⟦alist.singleton a b⟧

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

@[simp] lemma mem_singleton (x y : α) (b : β y) : x ∈ singleton y b ↔ x = y :=
by simp only [singleton]; erw [mem_cons_eq, mem_nil_iff, or_false]

section

variables [decidable_eq α]

instance has_decidable_eq [∀ a, decidable_eq (β a)] : decidable_eq (finmap β)
| s₁ s₂ := decidable_of_iff _ ext_iff

/-! ### lookup -/

/-- Look up the value associated to a key in a map. -/
def lookup (a : α) (s : finmap β) : option (β a) :=
lift_on s (lookup a) (λ s t, perm_lookup)

@[simp] theorem lookup_to_finmap (a : α) (s : alist β) :
  lookup a ⟦s⟧ = s.lookup a := rfl

@[simp] theorem lookup_list_to_finmap (a : α) (s : list (sigma β)) :
  lookup a s.to_finmap = s.lookup a :=
by rw [list.to_finmap, lookup_to_finmap, lookup_to_alist]

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

theorem lookup_is_some {a : α} {s : finmap β} :
  (s.lookup a).is_some ↔ a ∈ s :=
induction_on s $ λ s, alist.lookup_is_some

theorem lookup_eq_none {a} {s : finmap β} : lookup a s = none ↔ a ∉ s :=
induction_on s $ λ s, alist.lookup_eq_none

@[simp] lemma lookup_singleton_eq {a : α} {b : β a} : (singleton a b).lookup a = some b :=
by rw [singleton, lookup_to_finmap, alist.singleton, alist.lookup, lookup_cons_eq]

instance (a : α) (s : finmap β) : decidable (a ∈ s) :=
decidable_of_iff _ lookup_is_some

lemma mem_iff {a : α} {s : finmap β} : a ∈ s ↔ ∃ b, s.lookup a = some b :=
induction_on s $ λ s,
iff.trans list.mem_keys $ exists_congr $ λ b,
(mem_lookup_iff s.nodupkeys).symm

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

theorem ext_lookup {s₁ s₂ : finmap β} : (∀ x, s₁.lookup x = s₂.lookup x) → s₁ = s₂ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂ h,
begin
  simp only [alist.lookup, lookup_to_finmap] at h,
  rw [alist.to_finmap_eq],
  apply lookup_ext s₁.nodupkeys s₂.nodupkeys,
  intros x y,
  rw h,
end

/-! ### 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 β :=
lift_on s (λ t, ⟦replace a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_replace p

@[simp] theorem replace_to_finmap (a : α) (b : β a) (s : alist β) :
  replace a b ⟦s⟧ = ⟦s.replace a b⟧ := by simp [replace]

@[simp] theorem keys_replace (a : α) (b : β a) (s : finmap β) :
  (replace a b s).keys = s.keys :=
induction_on s $ λ s, by simp

@[simp] theorem mem_replace {a a' : α} {b : β a} {s : finmap β} :
  a' ∈ replace a b s ↔ a' ∈ s :=
induction_on s $ λ s, by simp

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 (λ d s, f d s.1 s.2) (λ d s t, H _ _ _ _ _) d

/-- `any f s` returns `tt` iff there exists a value `v` in `s` such that `f v = tt`. -/
def any (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x ∨ f y z) (by { intros,  simp [or.right_comm] }) ff

/-- `all f s` returns `tt` iff `f v = tt` for all values `v` in `s`. -/
def all (f : Π x, β x → bool) (s : finmap β) : bool :=
s.foldl (λ x y z, x ∧ f y z) (by { intros, simp [and.right_comm] }) ff

/-! ### erase -/

section

variables [decidable_eq α]

/-- Erase a key from the map. If the key is not present it does nothing. -/
def erase (a : α) (s : finmap β) : finmap β :=
lift_on s (λ t, ⟦erase a t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_erase p

@[simp] theorem erase_to_finmap (a : α) (s : alist β) :
  erase a ⟦s⟧ = ⟦s.erase a⟧ := by simp [erase]

@[simp]

@[simp] theorem keys_erase (a : α) (s : finmap β) :
  (erase a s).keys = s.keys.erase a :=
induction_on s $ λ s, by simp

@[simp] theorem mem_erase {a a' : α} {s : finmap β} : a' ∈ erase a s ↔ a' ≠ a ∧ a' ∈ s :=
induction_on s $ λ s, by simp

theorem not_mem_erase_self {a : α} {s : finmap β} : ¬ a ∈ erase a s :=
by rw [mem_erase, not_and_distrib, not_not]; left; refl

@[simp] theorem lookup_erase (a) (s : finmap β) : lookup a (erase a s) = none :=
induction_on s $ lookup_erase a

@[simp] theorem lookup_erase_ne {a a'} {s : finmap β} (h : a ≠ a') :
  lookup a (erase a' s) = lookup a s :=
induction_on s $ λ s, lookup_erase_ne h

theorem erase_erase {a a' : α} {s : finmap β} : erase a (erase a' s) = erase a' (erase a s) :=
induction_on s $ λ s, ext (by simp only [erase_erase, erase_to_finmap])

/-! ### 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 (λ s x _, s.erase x) (λ a₀ a₁ _ a₂ _, erase_erase) s

instance : has_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 β :=
lift_on s (λ t, ⟦insert a b t⟧) $
λ s₁ s₂ p, to_finmap_eq.2 $ perm_insert p

@[simp] theorem insert_to_finmap (a : α) (b : β a) (s : alist β) :
  insert a b ⟦s⟧ = ⟦s.insert a b⟧ := by simp [insert]

theorem insert_entries_of_neg {a : α} {b : β a} {s : finmap β} : a ∉ s →
  (insert a b s).entries = ⟨a, b⟩ ::ₘ s.entries :=
induction_on s $ λ s h,
by simp [insert_entries_of_neg (mt mem_to_finmap.1 h)]

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

@[simp] theorem lookup_insert {a} {b : β a} (s : finmap β) :
  lookup a (insert a b s) = some b :=
induction_on s $ λ s,
by simp only [insert_to_finmap, lookup_to_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 $ λ s,
by simp only [insert_to_finmap, lookup_to_finmap, lookup_insert_ne h]

@[simp] theorem insert_insert {a} {b b' : β a} (s : finmap β) :
  (s.insert a b).insert a b' = s.insert a b' :=
induction_on s $ λ s,
by simp only [insert_to_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 $ λ s,
by simp only [insert_to_finmap, alist.to_finmap_eq, insert_insert_of_ne _ h]

theorem to_finmap_cons (a : α) (b : β a) (xs : list (sigma β)) :
  list.to_finmap (⟨a,b⟩ :: xs) = insert a b xs.to_finmap := rfl

theorem mem_list_to_finmap (a : α) (xs : list (sigma β)) :
  a ∈ xs.to_finmap ↔ (∃ b : β a, sigma.mk a b ∈ xs) :=
by { induction xs with x xs; [skip, cases x];
     simp only [to_finmap_cons, *, not_mem_empty, exists_or_distrib, not_mem_nil, to_finmap_nil,
                exists_false, mem_cons_iff, mem_insert, exists_and_distrib_left];
     apply or_congr _ iff.rfl,
     conv { to_lhs, rw ← and_true (a = x_fst) },
     apply and_congr_right, rintro ⟨⟩, simp only [exists_eq, iff_self, heq_iff_eq] }

@[simp] theorem insert_singleton_eq {a : α} {b b' : β a} :
  insert a b (singleton a b') = singleton a b :=
by simp only [singleton, finmap.insert_to_finmap, alist.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 β :=
lift_on s (λ t, prod.map id to_finmap (extract a t)) $
λ s₁ s₂ p, by simp [perm_lookup p, to_finmap_eq, perm_erase p]

@[simp] theorem extract_eq_lookup_erase (a : α) (s : finmap β) :
  extract a s = (lookup a s, erase a s) :=
induction_on s $ λ s, by simp [extract]

/-! ### 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 β :=
lift_on₂ s₁ s₂ (λ s₁ s₂, ⟦s₁ ∪ s₂⟧) $
λ s₁ s₂ s₃ s₄ p₁₃ p₂₄, to_finmap_eq.mpr $ perm_union p₁₃ p₂₄

instance : has_union (finmap β) := ⟨union⟩

@[simp] theorem mem_union {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ ∪ s₂ ↔ a ∈ s₁ ∨ a ∈ s₂ :=
induction_on₂ s₁ s₂ $ λ _ _, mem_union

@[simp] theorem union_to_finmap (s₁ s₂ : alist β) : ⟦s₁⟧ ∪ ⟦s₂⟧ = ⟦s₁ ∪ s₂⟧ :=
by simp [(∪), union]

theorem keys_union {s₁ s₂ : finmap β} : (s₁ ∪ s₂).keys = s₁.keys ∪ s₂.keys :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, finset.ext $ by simp [keys]

@[simp] theorem lookup_union_left {a} {s₁ s₂ : finmap β} :
  a ∈ s₁ → lookup a (s₁ ∪ s₂) = lookup a s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂, 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₂ $ λ s₁ s₂, lookup_union_right

theorem lookup_union_left_of_not_in {a} {s₁ s₂ : finmap β} (h : a ∉ s₂) :
  lookup a (s₁ ∪ s₂) = lookup a s₁ :=
begin
  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'] }
end

@[simp] 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₂ $ λ s₁ s₂, 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₃ $ λ s₁ s₂ s₃, 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₂ $ λ a₁ a₂, by simp [insert_union]

theorem union_assoc {s₁ s₂ s₃ : finmap β} : (s₁ ∪ s₂) ∪ s₃ = s₁ ∪ (s₂ ∪ s₃) :=
induction_on₃ s₁ s₂ s₃ $ λ s₁ s₂ s₃,
by simp only [alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem empty_union {s₁ : finmap β} : ∅ ∪ s₁ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

@[simp] theorem union_empty {s₁ : finmap β} : s₁ ∪ ∅ = s₁ :=
induction_on s₁ $ λ s₁, by rw ← empty_to_finmap;
  simp [- empty_to_finmap, alist.to_finmap_eq, union_to_finmap, alist.union_assoc]

theorem erase_union_singleton (a : α) (b : β a) (s : finmap β) (h : s.lookup a = some b) :
  s.erase a ∪ singleton a b = s :=
ext_lookup
(λ 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, { rwa mem_singleton },
        rw [lookup_union_left_of_not_in this, lookup_erase_ne h'] } } )

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₂

lemma disjoint_empty (x : finmap β) : disjoint ∅ x .

@[symm]
lemma disjoint.symm (x y : finmap β) (h : disjoint x y) : disjoint y x :=
λ p hy hx, h p hx hy

lemma disjoint.symm_iff (x y : finmap β) : disjoint x y ↔ disjoint y x :=
⟨disjoint.symm x y, disjoint.symm y x⟩

section

variables [decidable_eq α]

instance : decidable_rel (@disjoint α β) :=
λ x y, by dsimp only [disjoint]; apply_instance

lemma 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_distrib, forall_and_distrib]

lemma 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]

theorem union_comm_of_disjoint {s₁ s₂ : finmap β} : disjoint s₁ s₂ → s₁ ∪ s₂ = s₂ ∪ s₁ :=
induction_on₂ s₁ s₂ $ λ s₁ s₂,
by { intros h, simp only [alist.to_finmap_eq, union_to_finmap, alist.union_comm_of_disjoint h] }

theorem union_cancel {s₁ s₂ s₃ : finmap β} (h : disjoint s₁ s₃) (h' : disjoint s₂ s₃) :
  s₁ ∪ s₃ = s₂ ∪ s₃ ↔ s₁ = s₂ :=
⟨λ h'', begin
          apply ext_lookup, intro x,
          have : (s₁ ∪ s₃).lookup x = (s₂ ∪ s₃).lookup x, from 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₂] } }
        end,
 λ h, h ▸ rfl⟩

end

end finmap


-- 3. higher order logic

import moromoro
import logic.basic

namespace hol

inductive type : Type
| base : type
| prop : type
| arrow : type → type → type
open type

variable ν : type → Type

inductive term : type → Type
| var : Π {t}, ν t → term t
| lam : Π {t₁ t₂}, (ν t₁ → term t₂) → term (arrow t₁ t₂)
| app : Π {t₁ t₂}, term (arrow t₁ t₂) → term t₁ → term t₂
| eq : Π {t}, term t → term t → term prop
open term

def Term (t : type) : Type 1 :=
Π ν, term ν t

def judgment : list type → type → Type :=
λ Γ t, list.foldr (λ t α, ν t → α) (term ν t) Γ

def Judgment (Γ : list type) (t : type) : Type 1 :=
Π ν, judgment ν Γ t

----

universe u
variables {α β : Type u}

inductive mem : α → list α → Type u
| here : Π {x l}, mem x (x :: l)
| there : Π {x l y}, mem x l → mem x (y :: l)
open mem

local infix ` ∈' `:50 := mem

variables {Γ Γ₁ Γ₂ : list type} {t t₁ t₂ t₃ : type}

def subst' : Π {t : type}, term (term ν) t → term ν t
| _ (var m) := m
| _ (lam f) := lam (λ x, subst' (f (var x)))
| _ (app m₁ m₂) := app (subst' m₁) (subst' m₂)
| _ (eq m₁ m₂) := eq (subst' m₁) (subst' m₂)

namespace judgment
  def weak : Judgment Γ t₂ → Judgment (t₁ :: Γ) t₂ :=
  λ m ν x, m ν

  def var' : Π {Γ}, judgment ν (t :: Γ) t
  | [] := λ x, var x
  | (t :: Γ) := λ x y, var' x

  def var : Π {Γ}, t ∈' Γ → Judgment Γ t
  | _ here := λ ν, var' ν
  | _ (there h) := weak (var h)

  def lam' : Π {Γ}, judgment ν (t₁ :: Γ) t₂ → judgment ν Γ (arrow t₁ t₂)
  | [] m := lam (λ x, m x)
  | (t :: Γ) f := λ x, lam' (λ y, f y x)

  def lam : Judgment (t₁ :: Γ) t₂ → Judgment Γ (arrow t₁ t₂) :=
  λ m ν, lam' ν (m ν)

  def app' : Π {Γ}, judgment ν Γ (arrow t₁ t₂) → judgment ν Γ t₁ → judgment ν Γ t₂
  | [] m₁ m₂ := app m₁ m₂
  | (t :: Γ) f m := λ x, app' (f x) (m x)

  def app : Judgment Γ (arrow t₁ t₂) → Judgment Γ t₁ → Judgment Γ t₂ :=
  λ m₁ m₂ ν, app' ν (m₁ ν) (m₂ ν)

  def eq' : Π {Γ : list type}, judgment ν Γ t → judgment ν Γ t → judgment ν Γ prop
  | [] m₁ m₂ := eq m₁ m₂
  | (t :: Γ) m₁ m₂ := λ x, eq' (m₁ x) (m₂ x)

  def eq : Judgment Γ t → Judgment Γ t → Judgment Γ prop :=
  λ m₁ m₂ ν, eq' ν (m₁ ν) (m₂ ν)

  def subst'' : Π {Γ}, judgment (term ν) (t₁ :: Γ) t₂ → judgment ν Γ t₁ → judgment ν Γ t₂
  | [] m₁ m₂ := subst' ν (m₁ m₂)
  | (t :: Γ) f m := λ x, subst'' (λ x', f x' (term.var x)) (m x)

  def subst : Judgment (t₁ :: Γ) t₂ → Judgment Γ t₁ → Judgment Γ t₂ :=
  λ m₁ m₂ ν, subst'' ν (m₁ _) (m₂ ν)
end judgment
open judgment

----

def type.foldr : list type → type → type :=
λ Γ t, list.foldr arrow t Γ

def judgment.to_term' : Π {Γ : list type}, judgment ν Γ t → term ν (type.foldr Γ t)
| [] m := m
| (t :: Γ) f := lam (λ x, judgment.to_term' (f x))

def judgment.to_term : Judgment Γ t → Term (type.foldr Γ t) :=
λ m ν, judgment.to_term' ν (m ν)

def term.to_judgment' : Π {Γ : list type}, term (term ν) (type.foldr Γ t) → judgment ν Γ t
| [] m := subst' ν m
| (t :: Γ) m :=
  match m with
  | (var x) := λ x, term.to_judgment' (app m (var (var x)))
  | (lam f) := λ x, term.to_judgment' (f (var x))
  | (app m₁ m₂) := λ x, term.to_judgment' (app m (var (var x)))
  end

def term.to_judgment : Term (type.foldr Γ t) → Judgment Γ t :=
λ m ν, term.to_judgment' ν (m _)

----

def domain : type → Type
| base := term ν base
| prop := term ν prop
| (arrow t₁ t₂) := domain t₁ → domain t₂

def Domain (t : type) : Type 1 :=
Π ν, domain ν t

def reify_reflect : Π (t : type), (domain ν t → term ν t) × (term ν t → domain ν t)
| base := ⟨ id, id ⟩
| prop := ⟨ id, id ⟩
| (arrow t₁ t₂) :=
   let r₁ := reify_reflect t₁ in
   let r₂ := reify_reflect t₂ in
   let reify (f : domain ν t₁ → domain ν t₂) := lam (λ x, r₂.1 (f (r₁.2 (var x)))) in
   let reflect (f : term ν (arrow t₁ t₂)) := λ x, r₂.2 (app f (r₁.1 x)) in
   ⟨reify, reflect⟩

def reify' : domain ν t → term ν t :=
λ x, (reify_reflect ν t).1 x

def reify : Domain t → Term t :=
λ x ν, reify' ν (x ν)

def eval' : Π {t : type}, term (domain ν) t → domain ν t
| _ (var x) := x
| _ (lam f) := λ x, eval' (f x)
| _ (app m₁ m₂) := (eval' m₁) (eval' m₂)
| _ (eq m₁ m₂) := eq (reify' ν (eval' m₁)) (reify' ν (eval' m₂))

def eval : Term t → Domain t :=
λ m ν, eval' ν (m _)

def normalize : Term t → Term t :=
reify ∘ eval

instance term_setoid : setoid (Term t) :=
⟨inv_image eq normalize,
 inv_image.equivalence eq normalize eq_equivalence⟩

instance judgment_setoid [h : setoid (Term (type.foldr Γ t))] : setoid (Judgment Γ t) :=
⟨inv_image h.r judgment.to_term,
 inv_image.equivalence h.r judgment.to_term h.iseqv⟩

meta def canonicity : tactic unit :=
`[ try { unfold has_equiv.equiv setoid.r inv_image }, try { reflexivity } ]

----

namespace term
  def top : Term prop :=
  λ ν, eq (lam (λ x : ν prop, var x)) (lam (λ x, var x))

  def and : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, eq (lam (λ f : ν (arrow _ (arrow _ prop)), app (app (var f) (top ν)) (top ν))) (lam (λ f, app (app (var f) (var p₁)) (var p₂)))))

  def Forall : Term (arrow (arrow t prop) prop) :=
  λ ν, lam (λ f, eq (var f) (lam (λ x, (top ν))))

  def bot : Term prop :=
  λ ν, app (Forall ν) (lam (λ p, var p))

  def implies : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, eq (app (app (and ν) (var p₁)) (var p₂)) (var p₁)))

  def not : Term (arrow prop prop) :=
  λ ν, lam (λ p, app (app (implies ν) (var p)) (bot ν))

  def iff : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, app (app (and ν) (app (app (implies ν) (var p₁)) (var p₂))) (app (app (implies ν) (var p₂)) (var p₁))))

  def or : Term (arrow prop (arrow prop prop)) :=
  λ ν, lam (λ p₁, lam (λ p₂, app (Forall ν) (lam (λ r, app (app (implies ν) (app (app (and ν) (app (app (implies ν) (var p₁)) (var r))) (app (app (implies ν) (var p₂)) (var r)))) (var r)))))

  def Exists : Term (arrow (arrow t prop) prop) :=
  λ ν, lam (λ f, app (Forall ν) (lam (λ r, app (app (implies ν) (app (Forall ν) (lam (λ x, app (app (implies ν) (app (var f) (var x))) (var r))))) (var r))))
end term
open term

#reduce @id (Judgment [] prop) $ app (app and top) (app (app or bot) top)

----

inductive Theorem : Π {Γ}, list (Judgment Γ prop) → Judgment Γ prop → Prop
| hyp : Π {Γ Φ} {φ : Judgment Γ prop}, φ ∈ Φ → Theorem Φ φ
| refl : Π {Γ Φ t} {m₁ m₂ : Judgment Γ t}, m₁ ≈ m₂ → Theorem Φ (eq m₁ m₂)
| subst : Π {Γ Φ t} (m : Judgment (t :: Γ) prop) (m₂ m₁ : Judgment Γ t), Theorem Φ (eq m₁ m₂) → Theorem Φ (subst m m₁) → Theorem Φ (subst m m₂)
| prop_ext : Π {Γ Φ} {φ₁ φ₂ : Judgment Γ prop}, Theorem (φ₁ :: Φ) φ₂ → Theorem (φ₂ :: Φ) φ₁ → Theorem Φ (eq φ₁ φ₂)
| fun_ext : Π {Γ Φ t₁ t₂} (m₁ m₂ : Judgment (t₁ :: Γ) t₂), Theorem (list.map weak Φ) (eq m₁ m₂) → Theorem Φ (eq (lam m₁) (lam m₂))

-- Let's prove!

example : @Theorem [prop] [var here] (eq (weak top) (var here)) :=
begin
  apply Theorem.prop_ext,
  { apply Theorem.hyp,
    simp },
  { apply Theorem.refl,
    canonicity }
end

example {φ₁ φ₂} {Φ : list (Judgment [] prop)} : Theorem Φ (app (app and φ₁) φ₂) → Theorem Φ φ₁ :=
begin
  intro p,
  apply Theorem.subst
    (var here)
    φ₁
    (λ ν, app (lam (λ f, app (app (var f) (φ₁ ν)) (φ₂ ν))) (lam (λ p₁, lam (λ p₂, var p₁)))),
  { apply Theorem.refl,
    canonicity, },
  { apply Theorem.subst
      (@id (Judgment [arrow _ prop] prop) $ λ ν f, app (var f) (lam (λ p₁, lam (λ p₂, var p₁))))
      (λ ν, lam (λ f, app (app (var f) (φ₁ ν)) (φ₂ ν)))
      (@id (Judgment [] (arrow _ prop)) $ λ ν, lam (λ f, app (app (var f) (top ν)) (top ν))),
    { apply Theorem.subst
        (var here)
        (eq
          (@id (Judgment [] (arrow _ prop)) $ λ ν, lam (λ f, app (app (var f) (top ν)) (top ν)))
          (λ ν, lam (λ f, app (app (var f) (φ₁ ν)) (φ₂ ν))))
        (λ ν, app (app (lam (λ p₁, lam (λ p₂, eq (lam (λ f : ν (arrow _ (arrow _ prop)), app (app (var f) (top ν)) (top ν))) (lam (λ f, app (app (var f) (var p₁)) (var p₂)))))) (φ₁ ν)) (φ₂ ν)),
      { apply Theorem.refl,
        canonicity },
      { from p } },
    { apply Theorem.subst
        (var here)
        (@id (Judgment [] _) $ λ ν, app (lam (λ f, app (app (var f) (top ν)) (top ν))) (lam (λ p₁, lam (λ p₂, var p₁))))
        top,
      { apply Theorem.refl,
        canonicity },
      { apply Theorem.refl,
        canonicity } } }
end

end hol


import galois.tactic
       .init .tail .inter .map_accum_lemmas .nth
       .take_drop_lemmas .preds .fin_nth .mem

universe u

def second {X A B : Type} (f : A -> B) : X × A -> X × B
| (x, y) := (x, f y)

lemma second_simpl {X A B : Type} (f : A -> B)
  (x : X) (y : A)
  : second f (x, y) = (x, f y)
  := rfl

namespace list

-- This runs a function over a list returning the intermediate results and a
-- a final result.
def map_accuml {α  σ β : Type} (f : σ → α → β × σ) : σ → list α → (list β × σ)
| c [] := ([], c)
| c (y::yr) :=
  let z := f c y in
  let r := map_accuml z.2 yr in
  (z.1 :: r.1, r.2)

def first_index_of_core {α : Type} (p : α → bool) : ℕ → list α → option (ℕ × α)
| c [] := option.none
| c (h::r) :=
  if p h = tt then
    option.some (c,h)
  else
    first_index_of_core (c+1) r

-- This searches a list for an element that satisfies a predicate.
--
-- If it finds an element, it returns the index and element.  Otherwise, it
-- returns none.
def first_index_of {α : Type} (p : α → bool) (l : list α) : option (ℕ × α) :=
  first_index_of_core p 0 l

def find_option {A} [decidable_eq A] (item: A) (l : list A) : option ℕ :=
let index := list.index_of item l in
if index = l.length then none else some index

lemma find_option_mem_len {A} [decidable_eq A] {x : A} {xs : list A}
  (H : x ∈ xs)
  : ∃ n, xs.find_option x = some n ∧ n < xs.length
:= begin
rw ← list.index_of_lt_length at H,
destruct (find_option x xs),
{ intros Hnone, exfalso,
  unfold find_option at Hnone, dsimp at Hnone,
  rw if_neg at Hnone, injection Hnone,
  apply ne_of_lt, assumption },
{ intros n Hn, constructor, split, assumption,
  unfold find_option at Hn, dsimp at Hn,
  have H : index_of x xs ≠ length xs,
  apply ne_of_lt, assumption,
  rw (if_neg H) at Hn, injection Hn with Hn',
  rw ← Hn', assumption
}
end

lemma find_option_mem {A} [decidable_eq A] {x : A} {xs : list A}
  (H : x ∈ xs)
  : ∃ n, xs.find_option x = some n
:= begin
apply_in H find_option_mem_len,
induction H with n H, induction H with H H',
constructor, assumption,
end

lemma find_index_append {A} {P : A → Prop} [decidable_pred P]
  (xs ys : list A)
  (n : ℕ)
  (Hn : n ≠ xs.length)
  (H : xs.find_index P = n)
  : (xs ++ ys).find_index P = n
:= begin
revert n,
induction xs; intros,
{ dsimp [list.index_of, list.find_index] at H, subst n,
  exfalso, apply Hn, reflexivity, },
{ dsimp [list.index_of, list.find_index] at H,
  rename a x,
  apply (if HPx : P x then _ else _),
  { rw (if_pos HPx) at H, subst n,
    dsimp [list.index_of, list.find_index],
    rw (if_pos HPx), },
  { rw (if_neg HPx) at H,
    dsimp, dsimp [list.index_of, list.find_index],
    rw (if_neg HPx),
    cases n, injection H,
    rename a n, injection H with H', clear H,
    f_equal, apply ih_1, intros contra, apply Hn,
    dsimp [list.length], dsimp [has_add.add, nat.add],
    f_equal, assumption, assumption
  }
}
end

lemma index_of_append {A} [decidable_eq A] (x : A) (xs ys : list A)
  (n : ℕ)
  (Hn : n ≠ xs.length)
  (H : list.index_of x xs = n)
  : list.index_of x (xs ++ ys) = n
:= begin
apply list.find_index_append; assumption
end

lemma not_not_iff {a : Prop} [decidable a] : ¬¬a ↔ a :=
iff.intro by_contradiction not_not_intro

lemma find_option_append {A} [decidable_eq A] (x : A) (xs ys : list A)
  (n : ℕ)
  (Hn : xs.find_option x = some n)
  : (xs ++ ys).find_option x = some n
:= begin
unfold find_option at Hn, dsimp at Hn,
apply (if H : list.index_of x xs = list.length xs then _ else _),
{ rw (if_pos H) at Hn, contradiction, },
{ rw (if_neg H) at Hn,
  injection Hn with Hn', clear Hn,
  dsimp, dsimp [find_option],
  rw list.index_of_append, tactic.rotate 2, assumption,
  tactic.swap, intros contra, apply H, subst n, assumption,
  rw list.index_of_eq_length at H, subst Hn',
  rw [not_not_iff] at H,
  rw ← list.index_of_lt_length at H,
  have H1 : list.index_of x xs ≠ list.length (xs ++ ys),
  apply ne_of_lt, rw list.length_append,
  apply lt_of_lt_of_le, assumption,
  rw add_comm,
  apply le_add_of_nonneg_left, apply nat.zero_le,
  simp [H1],
 }
end

lemma nth_cons_drop {A : Type} : forall h t n (i :A),
n ≠ 0 ->
list.nth (h :: t) (n) = some i ->
list.nth t (n - 1) = some i :=
begin
intros,
cases n,
{ contradiction },
{
  dsimp at *,
  simp at *,
  assumption,
}
end

lemma pair_induction_same_length {X Y}
  (P : list X → list Y → Sort u)
  (P0 : P [] [])
  (PS : ∀ x y xs ys, P xs ys → P (x :: xs) (y :: ys))
  (xs : list X) (ys : list Y) (H : xs.length = ys.length)
  : P xs ys
:= begin
revert xs, induction ys; intros; dsimp at H,
{ apply_in H list.eq_nil_of_length_eq_zero, subst xs,
  assumption, },
{ cases xs; dsimp at H, contradiction,
  apply PS, apply ih_1,
  apply nat.add_right_cancel, assumption,
}
end

lemma map_compose {A B C : Type}
  (f : A -> B) (g : B -> C) (xs : list A)
  : map (g ∘ f) xs = map g (map f xs)
:=
begin
induction xs,
{ reflexivity },
{ simp [map] }
end

lemma reverse_core_app {A : Type} (xs ys zs : list A)
  : list.reverse_core xs (ys ++ zs)
  = list.reverse_core xs ys ++ zs
:= begin
revert ys zs,
induction xs; intros,
{ simp [list.reverse_core] },
{ simp [list.reverse_core],
  rw <- list.cons_append,
  rw ih_1 }
end

lemma cons_reverse {A : Type} (x : A) (xs : list A)
  : list.reverse (x :: xs) = list.reverse xs ++ [x]
:=
begin
unfold list.reverse,
simp [list.reverse_core],
induction xs,
{ reflexivity },
{ simp [list.reverse_core],
  rw <- (reverse_core_app a_1 [a] [x]),
  dsimp, reflexivity
 }
end

lemma cons_reverse_app {A : Type} (x : A) (xs : list A)
: (list.reverse ∘ list.cons x) xs =
   ((λ xs, xs ++ [x]) ∘ list.reverse) xs
:=
begin
induction xs,
{ reflexivity },
{ simp [function.comp], }
end

lemma zip_same_length {X Y}
  (xs ys : list X) (xs' ys' : list Y) (H : xs.length = xs'.length)
  : zip (xs ++ ys) (xs' ++ ys')
  = zip xs xs' ++ zip ys ys'
:= begin
revert H xs' xs,
apply list.pair_induction_same_length,
reflexivity, intros, dsimp [list.zip, list.zip_with],
f_equal, assumption
end

lemma zip_map_r {X Y Z} (xs : list X) (ys : list Y)
  (f : Y → Z)
  : zip xs (map f ys) =
  list.map (second f) (list.zip xs ys)
:= begin
revert ys, induction xs; intros,
{ reflexivity },
{ cases ys,
  { reflexivity },
  { dsimp [list.zip, list.zip_with], f_equal,
    specialize (ih_1 a_3),
    unfold list.zip at ih_1,
    rw ih_1,
  }
 }
end

lemma map_fst_second {X A B : Type}
  (xs : list (X × A)) (f : A -> B)
  : map (prod.fst ∘ second f) xs
  = map prod.fst xs
:= begin
induction xs,
{ reflexivity },
{ simp only [list.map],
  cases a with i1 i2,
  simp only [second],
  rw ih_1, reflexivity
}
end

lemma map_not_nil {A B} (xs) (f : A -> B)
  (H : xs ≠ []) : list.map f xs ≠ [] :=
begin
cases xs,
{ contradiction },
{ simp [list.map], }
end

lemma map_nil {A B : Type} (f : A -> B)
  (xs : list A)
  (H : xs = [])
  : list.map f xs = []
  :=
begin
rw H, reflexivity
end

lemma repeat_length {A} (x : A) (n : ℕ)
  : (list.repeat x n).length = n
:= begin
induction n; simp [list.repeat, list.length],
end

end list

universe variable v

namespace list

variables {α : Type u} {β : Type v}

/- null theorems -/

-- Return true if list is empty
--
-- null x is equivalent to x = nil, but always decidable even if equality
-- of list elements is undecidable
def null : list α → Prop := λx, x = nil

instance null_decidable : ∀ xs : list α, decidable (null xs)
| nil := is_true (begin unfold null end)
| (x :: xs) := is_false (begin unfold null, contradiction end)

/- foldl theorem -/

-- Recursor to prove properties about a list and a left-fold over that list
protected
lemma foldl_rec_gen (P : list β → α → Prop)
                    (f : α → β → α)
                    (h : ∀(l : list β) (t : α) (e : β), P l t →  P (l ++ [e]) (f t e))
: ∀(r : list β) (s : α), P r s → ∀ (l : list β), P (r ++ l) (foldl f s l)
| r s p l :=
begin
  revert r s p,
  induction l,
  case list.nil { intros r s p, simp, exact p, },
  case list.cons e l ind {
    intros r s p,
    simp [foldl],
    have g := ind (r ++ [e]) (f s e) (h r s e p),
    simp at g,
    exact g,
  }
end

-- Recursor to prove properties about a list and a left-fold over that list
protected
theorem foldl_rec (P : list β → α → Prop)
                  (f : α → β → α)
                  (ind_step : ∀(l : list β) (t : α) (e : β), P l t →  P (l ++ [e]) (f t e))
                  (s : α)
                  (base_case : P nil s)
                  (l : list β)
: P l (foldl f s l) :=
  list.foldl_rec_gen P f ind_step nil s base_case l

def drop_last {a : Type} (l : list a) := list.remove_nth l (list.length l - 1)

end list


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

/-!
# Locally bounded maps

This file defines locally bounded maps between bornologies.

We use the `fun_like` design, so each type of morphisms has a companion typeclass which is meant to
be satisfied by itself and all stricter types.

## Types of morphisms

* `locally_bounded_map`: Locally bounded maps. Maps which preserve boundedness.

## Typeclasses

* `locally_bounded_map_class`
-/

open bornology filter function set

variables {F α β γ δ : Type*}

/-- The type of bounded maps from `α` to `β`, the maps which send a bounded set to a bounded set. -/
structure locally_bounded_map (α β : Type*) [bornology α] [bornology β] :=
(to_fun : α → β)
(comap_cobounded_le' : (cobounded β).comap to_fun ≤ cobounded α)

/-- `locally_bounded_map_class F α β` states that `F` is a type of bounded maps.

You should extend this class when you extend `locally_bounded_map`. -/
class locally_bounded_map_class (F : Type*) (α β : out_param $ Type*) [bornology α]
  [bornology β]
  extends fun_like F α (λ _, β) :=
(comap_cobounded_le (f : F) : (cobounded β).comap f ≤ cobounded α)

export locally_bounded_map_class (comap_cobounded_le)

lemma is_bounded.image [bornology α] [bornology β] [locally_bounded_map_class F α β] {f : F}
  {s : set α} (hs : is_bounded s) : is_bounded (f '' s) :=
comap_cobounded_le_iff.1 (comap_cobounded_le f) hs

instance [bornology α] [bornology β] [locally_bounded_map_class F α β] :
  has_coe_t F (locally_bounded_map α β) :=
⟨λ f, ⟨f, comap_cobounded_le f⟩⟩

namespace locally_bounded_map
variables [bornology α] [bornology β] [bornology γ]
  [bornology δ]

instance : locally_bounded_map_class (locally_bounded_map α β) α β :=
{ coe := λ f, f.to_fun,
  coe_injective' := λ f g h, by { cases f, cases g, congr' },
  comap_cobounded_le := λ f, f.comap_cobounded_le' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (locally_bounded_map α β) (λ _, α → β) := fun_like.has_coe_to_fun

@[simp] lemma to_fun_eq_coe {f : locally_bounded_map α β} : f.to_fun = (f : α → β) := rfl

@[ext] lemma ext {f g : locally_bounded_map α β} (h : ∀ a, f a = g a) : f = g := fun_like.ext f g h

/-- Copy of a `locally_bounded_map` with a new `to_fun` equal to the old one. Useful to fix
definitional equalities. -/
protected def copy (f : locally_bounded_map α β) (f' : α → β) (h : f' = f) :
  locally_bounded_map α β :=
⟨f', h.symm ▸ f.comap_cobounded_le'⟩

/-- Construct a `locally_bounded_map` from the fact that the function maps bounded sets to bounded
sets. -/
def of_map_bounded (f : α → β) (h) : locally_bounded_map α β := ⟨f, comap_cobounded_le_iff.2 h⟩

@[simp] lemma coe_of_map_bounded (f : α → β) {h} : ⇑(of_map_bounded f h) = f := rfl
@[simp] lemma of_map_bounded_apply (f : α → β) {h} (a : α) : of_map_bounded f h a = f a := rfl

variables (α)

/-- `id` as a `locally_bounded_map`. -/
protected def id : locally_bounded_map α α := ⟨id, comap_id.le⟩

instance : inhabited (locally_bounded_map α α) := ⟨locally_bounded_map.id α⟩

@[simp] lemma coe_id : ⇑(locally_bounded_map.id α) = id := rfl

variables {α}

@[simp] lemma id_apply (a : α) : locally_bounded_map.id α a = a := rfl

/-- Composition of `locally_bounded_map`s as a `locally_bounded_map`. -/
def comp (f : locally_bounded_map β γ) (g : locally_bounded_map α β) : locally_bounded_map α γ :=
{ to_fun := f ∘ g,
  comap_cobounded_le' :=
    comap_comap.ge.trans $ (comap_mono f.comap_cobounded_le').trans g.comap_cobounded_le' }

@[simp] lemma coe_comp (f : locally_bounded_map β γ) (g : locally_bounded_map α β) :
  ⇑(f.comp g) = f ∘ g := rfl
@[simp] lemma comp_apply (f : locally_bounded_map β γ) (g : locally_bounded_map α β) (a : α) :
  f.comp g a = f (g a) := rfl
@[simp] lemma comp_assoc (f : locally_bounded_map γ δ) (g : locally_bounded_map β γ)
  (h : locally_bounded_map α β) :
  (f.comp g).comp h = f.comp (g.comp h) := rfl
@[simp] lemma comp_id (f : locally_bounded_map α β) :
  f.comp (locally_bounded_map.id α) = f := ext $ λ a, rfl
@[simp] lemma id_comp (f : locally_bounded_map α β) :
  (locally_bounded_map.id β).comp f = f := ext $ λ a, rfl

lemma cancel_right {g₁ g₂ : locally_bounded_map β γ} {f : locally_bounded_map α β}
  (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, congr_arg _⟩

lemma cancel_left {g : locally_bounded_map β γ} {f₁ f₂ : locally_bounded_map α β}
  (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ a, hg $ by rw [←comp_apply, h, comp_apply], congr_arg _⟩

end locally_bounded_map