/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.rbtree.find

universes u v

namespace Mathlib

namespace rbnode

@[simp] theorem balance1_eq₁ {α : Type u} (l : rbnode α) (x : α) (r₁ : rbnode α) (y : α) (r₂ : rbnode α) (v : α) (t : rbnode α) : balance1 (red_node l x r₁) y r₂ v t = red_node (black_node l x r₁) y (black_node r₂ v t) := sorry

@[simp] theorem balance1_eq₂ {α : Type u} (l₁ : rbnode α) (y : α) (l₂ : rbnode α) (x : α) (r : rbnode α) (v : α) (t : rbnode α) : get_color l₁ ≠ color.red → balance1 l₁ y (red_node l₂ x r) v t = red_node (black_node l₁ y l₂) x (black_node r v t) := sorry

@[simp] theorem balance1_eq₃ {α : Type u} (l : rbnode α) (y : α) (r : rbnode α) (v : α) (t : rbnode α) : get_color l ≠ color.red → get_color r ≠ color.red → balance1 l y r v t = black_node (red_node l y r) v t := sorry

@[simp] theorem balance2_eq₁ {α : Type u} (l : rbnode α) (x₁ : α) (r₁ : rbnode α) (y : α) (r₂ : rbnode α) (v : α) (t : rbnode α) : balance2 (red_node l x₁ r₁) y r₂ v t = red_node (black_node t v l) x₁ (black_node r₁ y r₂) := sorry

@[simp] theorem balance2_eq₂ {α : Type u} (l₁ : rbnode α) (y : α) (l₂ : rbnode α) (x₂ : α) (r₂ : rbnode α) (v : α) (t : rbnode α) : get_color l₁ ≠ color.red → balance2 l₁ y (red_node l₂ x₂ r₂) v t = red_node (black_node t v l₁) y (black_node l₂ x₂ r₂) := sorry

@[simp] theorem balance2_eq₃ {α : Type u} (l : rbnode α) (y : α) (r : rbnode α) (v : α) (t : rbnode α) : get_color l ≠ color.red → get_color r ≠ color.red → balance2 l y r v t = black_node t v (red_node l y r) := sorry

/- We can use the same induction principle for balance1 and balance2 -/

theorem balance.cases {α : Type u} {p : rbnode α → α → rbnode α → Prop} (l : rbnode α) (y : α) (r : rbnode α) (red_left : ∀ (l : rbnode α) (x : α) (r₁ : rbnode α) (y : α) (r₂ : rbnode α), p (red_node l x r₁) y r₂) (red_right : ∀ (l₁ : rbnode α) (y : α) (l₂ : rbnode α) (x : α) (r : rbnode α), get_color l₁ ≠ color.red → p l₁ y (red_node l₂ x r)) (other : ∀ (l : rbnode α) (y : α) (r : rbnode α), get_color l ≠ color.red → get_color r ≠ color.red → p l y r) : p l y r := sorry

theorem balance1_ne_leaf {α : Type u} (l : rbnode α) (x : α) (r : rbnode α) (v : α) (t : rbnode α) : balance1 l x r v t ≠ leaf := sorry

theorem balance1_node_ne_leaf {α : Type u} {s : rbnode α} (a : α) (t : rbnode α) : s ≠ leaf → balance1_node s a t ≠ leaf := sorry

theorem balance2_ne_leaf {α : Type u} (l : rbnode α) (x : α) (r : rbnode α) (v : α) (t : rbnode α) : balance2 l x r v t ≠ leaf := sorry

theorem balance2_node_ne_leaf {α : Type u} {s : rbnode α} (a : α) (t : rbnode α) : s ≠ leaf → balance2_node s a t ≠ leaf := sorry

theorem ins.induction {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {p : rbnode α → Prop} (t : rbnode α) (x : α) (is_leaf : p leaf) (is_red_lt : ∀ (a : rbnode α) (y : α) (b : rbnode α), cmp_using lt x y = ordering.lt → p a → p (red_node a y b)) (is_red_eq : ∀ (a : rbnode α) (y : α) (b : rbnode α), cmp_using lt x y = ordering.eq → p (red_node a y b)) (is_red_gt : ∀ (a : rbnode α) (y : α) (b : rbnode α), cmp_using lt x y = ordering.gt → p b → p (red_node a y b)) (is_black_lt_red : ∀ (a : rbnode α) (y : α) (b : rbnode α),
  cmp_using lt x y = ordering.lt → get_color a = color.red → p a → p (black_node a y b)) (is_black_lt_not_red : ∀ (a : rbnode α) (y : α) (b : rbnode α),
  cmp_using lt x y = ordering.lt → get_color a ≠ color.red → p a → p (black_node a y b)) (is_black_eq : ∀ (a : rbnode α) (y : α) (b : rbnode α), cmp_using lt x y = ordering.eq → p (black_node a y b)) (is_black_gt_red : ∀ (a : rbnode α) (y : α) (b : rbnode α),
  cmp_using lt x y = ordering.gt → get_color b = color.red → p b → p (black_node a y b)) (is_black_gt_not_red : ∀ (a : rbnode α) (y : α) (b : rbnode α),
  cmp_using lt x y = ordering.gt → get_color b ≠ color.red → p b → p (black_node a y b)) : p t := sorry

theorem is_searchable_balance1 {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {l : rbnode α} {y : α} {r : rbnode α} {v : α} {t : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt l lo (some y) →
  is_searchable lt r (some y) (some v) → is_searchable lt t (some v) hi → is_searchable lt (balance1 l y r v t) lo hi := sorry

theorem is_searchable_balance1_node {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {t : rbnode α} [is_trans α lt] {y : α} {s : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt t lo (some y) → is_searchable lt s (some y) hi → is_searchable lt (balance1_node t y s) lo hi := sorry

theorem is_searchable_balance2 {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {l : rbnode α} {y : α} {r : rbnode α} {v : α} {t : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt t lo (some v) →
  is_searchable lt l (some v) (some y) → is_searchable lt r (some y) hi → is_searchable lt (balance2 l y r v t) lo hi := sorry

theorem is_searchable_balance2_node {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {t : rbnode α} [is_trans α lt] {y : α} {s : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt s lo (some y) → is_searchable lt t (some y) hi → is_searchable lt (balance2_node t y s) lo hi := sorry

theorem is_searchable_ins {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {t : rbnode α} {x : α} [is_strict_weak_order α lt] {lo : Option α} {hi : Option α} (h : is_searchable lt t lo hi) : lift lt lo (some x) → lift lt (some x) hi → is_searchable lt (ins lt t x) lo hi := sorry

theorem is_searchable_mk_insert_result {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {c : color} {t : rbnode α} : is_searchable lt t none none → is_searchable lt (mk_insert_result c t) none none := sorry

theorem is_searchable_insert {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {t : rbnode α} {x : α} [is_strict_weak_order α lt] : is_searchable lt t none none → is_searchable lt (insert lt t x) none none := sorry

end rbnode

namespace rbnode

theorem mem_balance1_node_of_mem_left {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {x : α} {s : rbnode α} (v : α) (t : rbnode α) : mem lt x s → mem lt x (balance1_node s v t) := sorry

theorem mem_balance2_node_of_mem_left {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {x : α} {s : rbnode α} (v : α) (t : rbnode α) : mem lt x s → mem lt x (balance2_node s v t) := sorry

theorem mem_balance1_node_of_mem_right {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {x : α} {t : rbnode α} (v : α) (s : rbnode α) : mem lt x t → mem lt x (balance1_node s v t) := sorry

theorem mem_balance2_node_of_mem_right {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {x : α} {t : rbnode α} (v : α) (s : rbnode α) : mem lt x t → mem lt x (balance2_node s v t) := sorry

theorem mem_balance1_node_of_incomp {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {x : α} {v : α} (s : rbnode α) (t : rbnode α) : ¬lt x v ∧ ¬lt v x → s ≠ leaf → mem lt x (balance1_node s v t) := sorry

theorem mem_balance2_node_of_incomp {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {x : α} {v : α} (s : rbnode α) (t : rbnode α) : ¬lt v x ∧ ¬lt x v → s ≠ leaf → mem lt x (balance2_node s v t) := sorry

theorem ins_ne_leaf {α : Type u} (lt : α → α → Prop) [DecidableRel lt] (t : rbnode α) (x : α) : ins lt t x ≠ leaf := sorry

theorem insert_ne_leaf {α : Type u} (lt : α → α → Prop) [DecidableRel lt] (t : rbnode α) (x : α) : insert lt t x ≠ leaf := sorry

theorem mem_ins_of_incomp {α : Type u} (lt : α → α → Prop) [DecidableRel lt] (t : rbnode α) {x : α} {y : α} (h : ¬lt x y ∧ ¬lt y x) : mem lt x (ins lt t y) := sorry

theorem mem_ins_of_mem {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} (z : α) {x : α} (h : mem lt x t) : mem lt x (ins lt t z) := sorry

theorem mem_mk_insert_result {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {a : α} {t : rbnode α} (c : color) : mem lt a t → mem lt a (mk_insert_result c t) := sorry

theorem mem_of_mem_mk_insert_result {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {a : α} {t : rbnode α} {c : color} : mem lt a (mk_insert_result c t) → mem lt a t := sorry

theorem mem_insert_of_incomp {α : Type u} (lt : α → α → Prop) [DecidableRel lt] (t : rbnode α) {x : α} {y : α} (h : ¬lt x y ∧ ¬lt y x) : mem lt x (insert lt t y) := sorry

theorem mem_insert_of_mem {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {x : α} (z : α) : mem lt x t → mem lt x (insert lt t z) :=
  fun (ᾰ : mem lt x t) => mem_mk_insert_result lt (get_color t) (mem_ins_of_mem lt z ᾰ)

theorem of_mem_balance1_node {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {s : rbnode α} {v : α} {t : rbnode α} : mem lt x (balance1_node s v t) → mem lt x s ∨ ¬lt x v ∧ ¬lt v x ∨ mem lt x t := sorry

theorem of_mem_balance2_node {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {s : rbnode α} {v : α} {t : rbnode α} : mem lt x (balance2_node s v t) → mem lt x s ∨ ¬lt x v ∧ ¬lt v x ∨ mem lt x t := sorry

theorem equiv_or_mem_of_mem_ins {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {x : α} {z : α} (h : mem lt x (ins lt t z)) : strict_weak_order.equiv x z ∨ mem lt x t := sorry

theorem equiv_or_mem_of_mem_insert {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {x : α} {z : α} (h : mem lt x (insert lt t z)) : strict_weak_order.equiv x z ∨ mem lt x t := sorry

theorem mem_exact_balance1_node_of_mem_exact {α : Type u} {x : α} {s : rbnode α} (v : α) (t : rbnode α) : mem_exact x s → mem_exact x (balance1_node s v t) := sorry

theorem mem_exact_balance2_node_of_mem_exact {α : Type u} {x : α} {s : rbnode α} (v : α) (t : rbnode α) : mem_exact x s → mem_exact x (balance2_node s v t) := sorry

theorem find_balance1_node {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {y : α} {z : α} {t : rbnode α} {s : rbnode α} {lo : Option α} {hi : Option α} : is_searchable lt t lo (some z) →
  is_searchable lt s (some z) hi →
    find lt t y = some x → strict_weak_order.equiv y x → find lt (balance1_node t z s) y = some x := sorry

theorem find_balance2_node {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {y : α} {z : α} {s : rbnode α} {t : rbnode α} [is_trans α lt] {lo : Option α} {hi : Option α} : is_searchable lt s lo (some z) →
  is_searchable lt t (some z) hi →
    find lt t y = some x → strict_weak_order.equiv y x → find lt (balance2_node t z s) y = some x := sorry

/- Auxiliary lemma -/

theorem ite_eq_of_not_lt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_order α lt] {a : α} {b : α} {β : Type v} (t : β) (s : β) (h : lt b a) : ite (lt a b) t s = s := sorry

theorem find_ins_of_eqv {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {y : α} {t : rbnode α} (he : strict_weak_order.equiv x y) {lo : Option α} {hi : Option α} (hs : is_searchable lt t lo hi) (hlt₁ : lift lt lo (some x)) (hlt₂ : lift lt (some x) hi) : find lt (ins lt t x) y = some x := sorry

theorem find_mk_insert_result {α : Type u} (lt : α → α → Prop) [DecidableRel lt] (c : color) (t : rbnode α) (x : α) : find lt (mk_insert_result c t) x = find lt t x := sorry

theorem find_insert_of_eqv {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {y : α} {t : rbnode α} (he : strict_weak_order.equiv x y) : is_searchable lt t none none → find lt (insert lt t x) y = some x := sorry

theorem weak_trichotomous {α : Type u} (lt : α → α → Prop) [DecidableRel lt] (x : α) (y : α) {p : Prop} (is_lt : lt x y → p) (is_eqv : ¬lt x y ∧ ¬lt y x → p) (is_gt : lt y x → p) : p :=
  dite (lt x y) (fun (h : lt x y) => dite (lt y x) (fun (h_1 : lt y x) => is_lt h) fun (h_1 : ¬lt y x) => is_lt h)
    fun (h : ¬lt x y) =>
      dite (lt y x) (fun (h : lt y x) => is_gt h) fun (h_1 : ¬lt y x) => is_eqv { left := h, right := h_1 }

theorem find_black_eq_find_red {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {l : rbnode α} {y : α} {r : rbnode α} {x : α} : find lt (black_node l y r) x = find lt (red_node l y r) x := sorry

theorem find_red_of_lt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {l : rbnode α} {y : α} {r : rbnode α} {x : α} (h : lt x y) : find lt (red_node l y r) x = find lt l x := sorry

theorem find_red_of_gt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_order α lt] {l : rbnode α} {y : α} {r : rbnode α} {x : α} (h : lt y x) : find lt (red_node l y r) x = find lt r x := sorry

theorem find_red_of_incomp {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {l : rbnode α} {y : α} {r : rbnode α} {x : α} (h : ¬lt x y ∧ ¬lt y x) : find lt (red_node l y r) x = some y := sorry

theorem find_balance1_lt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {l : rbnode α} {r : rbnode α} {t : rbnode α} {v : α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : lt x y) (hl : is_searchable lt l lo (some v)) (hr : is_searchable lt r (some v) (some y)) (ht : is_searchable lt t (some y) hi) : find lt (balance1 l v r y t) x = find lt (red_node l v r) x := sorry

theorem find_balance1_node_lt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {s : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (hlt : lt y x) (ht : is_searchable lt t lo (some x)) (hs : is_searchable lt s (some x) hi) (hne : autoParam (t ≠ leaf)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.rbnode.ins_ne_leaf_tac")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "rbnode") "ins_ne_leaf_tac") [])) : find lt (balance1_node t x s) y = find lt t y := sorry

theorem find_balance1_gt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {l : rbnode α} {r : rbnode α} {t : rbnode α} {v : α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : lt y x) (hl : is_searchable lt l lo (some v)) (hr : is_searchable lt r (some v) (some y)) (ht : is_searchable lt t (some y) hi) : find lt (balance1 l v r y t) x = find lt t x := sorry

theorem find_balance1_node_gt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {s : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : lt x y) (ht : is_searchable lt t lo (some x)) (hs : is_searchable lt s (some x) hi) (hne : autoParam (t ≠ leaf)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.rbnode.ins_ne_leaf_tac")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "rbnode") "ins_ne_leaf_tac") [])) : find lt (balance1_node t x s) y = find lt s y := sorry

theorem find_balance1_eqv {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {l : rbnode α} {r : rbnode α} {t : rbnode α} {v : α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : ¬lt x y ∧ ¬lt y x) (hl : is_searchable lt l lo (some v)) (hr : is_searchable lt r (some v) (some y)) (ht : is_searchable lt t (some y) hi) : find lt (balance1 l v r y t) x = some y := sorry

theorem find_balance1_node_eqv {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {s : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : ¬lt x y ∧ ¬lt y x) (ht : is_searchable lt t lo (some y)) (hs : is_searchable lt s (some y) hi) (hne : autoParam (t ≠ leaf)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.rbnode.ins_ne_leaf_tac")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "rbnode") "ins_ne_leaf_tac") [])) : find lt (balance1_node t y s) x = some y := sorry

theorem find_balance2_lt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {l : rbnode α} {v : α} {r : rbnode α} {t : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : lt x y) (hl : is_searchable lt l (some y) (some v)) (hr : is_searchable lt r (some v) hi) (ht : is_searchable lt t lo (some y)) : find lt (balance2 l v r y t) x = find lt t x := sorry

theorem find_balance2_node_lt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {s : rbnode α} {t : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : lt x y) (ht : is_searchable lt t (some y) hi) (hs : is_searchable lt s lo (some y)) (hne : autoParam (t ≠ leaf)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.rbnode.ins_ne_leaf_tac")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "rbnode") "ins_ne_leaf_tac") [])) : find lt (balance2_node t y s) x = find lt s x := sorry

theorem find_balance2_gt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {l : rbnode α} {v : α} {r : rbnode α} {t : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : lt y x) (hl : is_searchable lt l (some y) (some v)) (hr : is_searchable lt r (some v) hi) (ht : is_searchable lt t lo (some y)) : find lt (balance2 l v r y t) x = find lt (red_node l v r) x := sorry

theorem find_balance2_node_gt {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {s : rbnode α} {t : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : lt y x) (ht : is_searchable lt t (some y) hi) (hs : is_searchable lt s lo (some y)) (hne : autoParam (t ≠ leaf)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.rbnode.ins_ne_leaf_tac")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "rbnode") "ins_ne_leaf_tac") [])) : find lt (balance2_node t y s) x = find lt t x := sorry

theorem find_balance2_eqv {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {l : rbnode α} {v : α} {r : rbnode α} {t : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : ¬lt x y ∧ ¬lt y x) (hl : is_searchable lt l (some y) (some v)) (hr : is_searchable lt r (some v) hi) (ht : is_searchable lt t lo (some y)) : find lt (balance2 l v r y t) x = some y := sorry

theorem find_balance2_node_eqv {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {t : rbnode α} {s : rbnode α} {x : α} {y : α} {lo : Option α} {hi : Option α} (h : ¬lt x y ∧ ¬lt y x) (ht : is_searchable lt t (some y) hi) (hs : is_searchable lt s lo (some y)) (hne : autoParam (t ≠ leaf)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.rbnode.ins_ne_leaf_tac")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "rbnode") "ins_ne_leaf_tac") [])) : find lt (balance2_node t y s) x = some y := sorry

theorem find_ins_of_disj {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {y : α} {t : rbnode α} (hn : lt x y ∨ lt y x) {lo : Option α} {hi : Option α} (hs : is_searchable lt t lo hi) (hlt₁ : lift lt lo (some x)) (hlt₂ : lift lt (some x) hi) : find lt (ins lt t x) y = find lt t y := sorry

theorem find_insert_of_disj {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {y : α} {t : rbnode α} (hd : lt x y ∨ lt y x) : is_searchable lt t none none → find lt (insert lt t x) y = find lt t y := sorry

theorem find_insert_of_not_eqv {α : Type u} (lt : α → α → Prop) [DecidableRel lt] [is_strict_weak_order α lt] {x : α} {y : α} {t : rbnode α} (hn : ¬strict_weak_order.equiv x y) : is_searchable lt t none none → find lt (insert lt t x) y = find lt t y := sorry

inductive is_bad_red_black {α : Type u} : rbnode α → ℕ → Prop
where
| bad_red : ∀ {c₁ c₂ : color} {n : ℕ} {l r : rbnode α} {v : α},
  is_red_black l c₁ n → is_red_black r c₂ n → is_bad_red_black (red_node l v r) n

theorem balance1_rb {α : Type u} {l : rbnode α} {r : rbnode α} {t : rbnode α} {y : α} {v : α} {c_l : color} {c_r : color} {c_t : color} {n : ℕ} : is_red_black l c_l n →
  is_red_black r c_r n → is_red_black t c_t n → ∃ (c : color), is_red_black (balance1 l y r v t) c (Nat.succ n) := sorry

theorem balance2_rb {α : Type u} {l : rbnode α} {r : rbnode α} {t : rbnode α} {y : α} {v : α} {c_l : color} {c_r : color} {c_t : color} {n : ℕ} : is_red_black l c_l n →
  is_red_black r c_r n → is_red_black t c_t n → ∃ (c : color), is_red_black (balance2 l y r v t) c (Nat.succ n) := sorry

theorem balance1_node_rb {α : Type u} {t : rbnode α} {s : rbnode α} {y : α} {c : color} {n : ℕ} : is_bad_red_black t n → is_red_black s c n → ∃ (c : color), is_red_black (balance1_node t y s) c (Nat.succ n) := sorry

theorem balance2_node_rb {α : Type u} {t : rbnode α} {s : rbnode α} {y : α} {c : color} {n : ℕ} : is_bad_red_black t n → is_red_black s c n → ∃ (c : color), is_red_black (balance2_node t y s) c (Nat.succ n) := sorry

def ins_rb_result {α : Type u} : rbnode α → color → ℕ → Prop :=
  sorry

theorem of_get_color_eq_red {α : Type u} {t : rbnode α} {c : color} {n : ℕ} : get_color t = color.red → is_red_black t c n → c = color.red := sorry

theorem of_get_color_ne_red {α : Type u} {t : rbnode α} {c : color} {n : ℕ} : get_color t ≠ color.red → is_red_black t c n → c = color.black := sorry

theorem ins_rb {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {t : rbnode α} (x : α) {c : color} {n : ℕ} (h : is_red_black t c n) : ins_rb_result (ins lt t x) c n := sorry

def insert_rb_result {α : Type u} : rbnode α → color → ℕ → Prop :=
  sorry

theorem insert_rb {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {t : rbnode α} (x : α) {c : color} {n : ℕ} (h : is_red_black t c n) : insert_rb_result (insert lt t x) c n := sorry

theorem insert_is_red_black {α : Type u} (lt : α → α → Prop) [DecidableRel lt] {t : rbnode α} {c : color} {n : ℕ} (x : α) : is_red_black t c n → ∃ (c : color), ∃ (n : ℕ), is_red_black (insert lt t x) c n := sorry


import tactic
import tactic.linarith
import tactic.norm_num
import data.sigma.fst
import category.basic

universes u

structure ref (α : Type u) : Type u :=
(addr : ℕ)

def value := Σ α : Type u, α

namespace intl

inductive st (α : Type u) : Type.{u+1}
| pure (x : α) : st
| new_ref {β : Type u} : β → (ref β → st) → st
| read {β : Type u} : ref β → (β → st) → st
| write {β : Type u} : β → ref β → (punit.{u+1} → st) → st

end intl

export intl (st)

namespace st

variables {α β : Type u}
open intl.st (hiding pure)

protected def bind : Π (x : st α) (f : α → st β), st β
| (intl.st.pure x) f := f x
| (new_ref x f) g := new_ref x $ λ r, bind (f r) g
| (read r f) g := read r $ λ v, bind (f v) g
| (write v r f) g := write v r $ λ v, bind (f v) g

def addr : sigma ref → ℕ
| ⟨_,⟨_,x⟩⟩ := x

instance : monad.{u u+1} st :=
{ pure := @intl.st.pure,
  bind := @st.bind }

instance : is_lawful_monad.{u u+1} st :=
begin
  refine { .. }; intros; try { refl <|> dsimp [(>>=),(<$>)] };
  induction x; simp [(>>=),(<$>),st.bind] with functor_norm;
  ext; simp *,
end

inductive ref_layout : list (sigma ref) → Prop
| nil : ref_layout []
| cons (r : sigma ref) (xs : list (sigma ref)) :
  ¬ addr r ∈ xs.map addr →
  ref_layout xs →
  ref_layout (r :: xs)

inductive mem_safety : list (sigma ref.{u}) → Π {α}, st.{u} α → Prop
| pure (ls) {α} (x : α) : mem_safety ls (pure x)
| new_ref (ls) {α β} (x : α) (f : ref α → st β) :
  (∀ (r : ref α),
    let r' := sigma.mk α r in
    ¬ r' ∈ ls →
    mem_safety (r' :: ls) (f r)) →
  mem_safety ls (new_ref x f)
| read (ls) {β} (r : ref β) {α} (f : β → st α) :
  sigma.mk β r ∈ ls →
  (∀ x, mem_safety ls (f x)) →
  mem_safety ls (read r f)
| write (ls) {β} (r : ref β) (x : β) {α} (f : punit → st α) :
  sigma.mk _ r ∈ ls →
  mem_safety ls (f punit.star) →
  mem_safety ls (write x r f)

lemma mem_safety_bind {ls} {x : st β} {f : β → st α}
  (h₀ : mem_safety ls x)
  (h₁ : ∀ ls' i, ls ⊆ ls' → mem_safety ls' (f i)) :
  mem_safety ls (st.bind x f) :=
begin
  induction h₀ generalizing f; simp only [st.bind,pure],
  { apply h₁, refl },
  { constructor, intros, apply h₀_ih, assumption,
    intros, apply h₁, transitivity ; [skip, exact a_1],
    apply list.subset_cons_of_subset, refl },
  { constructor, assumption, intros, apply h₀_ih _ h₁, },
  { constructor, assumption, apply h₀_ih h₁, },
end

def alloc (α : Type u) (ls : list (sigma ref.{u})) : ref α :=
⟨ _, ls.length ⟩

structure mem (ls : list (sigma ref.{u})) :=
(vals : array ls.length value.{u})
(valid_ptrs : ∀ x : sigma ref, x ∈ ls → x.2.addr < ls.length)
(well_typed : ∀ (x : sigma ref) (h : x ∈ ls), (vals.read ⟨x.2.addr,valid_ptrs _ h⟩).1 = x.1 )

local notation `♯` := by assumption

lemma same_type_of_same_addr {ls : list (sigma ref)} (m : mem ls) (r₀ ∈ ls) (r₁ ∈ ls)
  (h : r₀.2.addr = r₁.2.addr) :
  r₀.1 = r₁.1 :=
calc  r₀.1
    = (m.vals.read ⟨r₀.2.addr,m.valid_ptrs _ ♯⟩).1 : by rw m.well_typed
... = (m.vals.read ⟨r₁.2.addr,m.valid_ptrs _ ♯⟩).1 : by { casesm* [sigma _,ref _], cases h, refl }
... = r₁.1 : by rw m.well_typed

def mem.read {ls : list (sigma ref.{u})} {α} (r : ref α) (h : sigma.mk α r ∈ ls) (m : mem ls) : α :=
cast (m.well_typed _ h) (m.vals.read ⟨r.addr,m.valid_ptrs _ h⟩).2

def mem.write {ls : list (sigma ref.{u})} {α} (x : α) (r : ref α) (h : sigma.mk _ r ∈ ls) (m : mem ls) : mem ls :=
{ vals := m.vals.write ⟨r.addr,m.valid_ptrs _ h⟩ ⟨α,x⟩,
  well_typed := by { intros,
                     by_cases h' : r.addr = (x_1.snd).addr,
                     { cases r, cases h', rw array.read_write,
                       exact same_type_of_same_addr m _ h _ h_1 h', },
                     { rw array.read_write_of_ne, apply m.well_typed,
                       intro, injection a, contradiction } },
  .. m  }

def mem.alloc {ls : list (sigma ref.{u})} {α} (x : α) (m : mem ls) : mem (⟨α,⟨_,ls.length⟩⟩ :: ls) :=
{ vals := m.vals.push_back ⟨_,x⟩,
  valid_ptrs := by { rintro _ ⟨_ | _⟩, norm_num, dsimp,
                     transitivity ls.length, apply m.valid_ptrs _ ♯, norm_num },
  well_typed := by { rintros _ ⟨ _ | _ ⟩,
                     { simp [array.read,array.push_back,d_array.read] },
                     have : (x_1.snd).addr ≠ list.length ls,
                     { apply ne_of_lt, apply m.valid_ptrs _ h },
                     { simp [array.read,array.push_back,d_array.read,*],
                       apply m.well_typed _ h, } }
   }

lemma alloc_free {ls : list (sigma ref)} (m : mem ls) : sigma.mk α (alloc α ls) ∉ ls :=
begin
  dsimp [alloc], intro h,
  have := m.valid_ptrs _ h,
  dsimp at this, apply lt_irrefl _ this
end

def mem₀ : mem [] :=
{ vals := array.nil,
  valid_ptrs := by rintro _ ⟨ ⟩,
  well_typed := by rintro _ ⟨ ⟩ }

def run' {α} : Π ls (x : st α), mem ls → mem_safety ls x → α
| ls (intl.st.pure a) m _ := a
| ls (@new_ref _ α x f) m h :=
  run' (sigma.mk _ _ :: ls) (f _) (m.alloc x)
    (by cases h; apply h_a _ (alloc_free m))
| ls (@read _ α r f) m h :=
  run' ls (f $ m.read r $ by { cases h, assumption }) ♯
    (by cases h; apply h_a_1)
| ls (@write _ α x r f) m h :=
  run' ls (f ()) (m.write x r $ by { cases h, assumption })
  $ by { cases h, assumption }

def run {α} (x : st α) (h : mem_safety [] x) : α :=
run' [] x mem₀ h

run_cmd mk_simp_attr `st

attribute [st] st.bind

@[st]
def new_ref (x : α) : st (ref α) :=
intl.st.new_ref x pure

@[st]
def write (r : ref α) (x : α) : st punit :=
intl.st.write x r pure

@[st]
def read (r : ref α) : st α :=
intl.st.read r pure

def ex (x x' : α) : st (α × α) :=
do r ← new_ref x,
   y ← read r,
   write r x',
   prod.mk y <$> read r

lemma ex_safe : ∀ x x' : α, mem_safety [] (ex x x') :=
begin
  intros, simp [ex,(>>=),(<$>),pure] with st,
  constructor, intros,
  constructor, simp, intros,
  constructor, simp, intros,
  constructor, simp, intros,
  constructor
end

#eval run (ex 1 3) (ex_safe 1 3)

def swap (r r' : ref α) : st punit :=
do t ← read r >>= new_ref,
   read r' >>= write r,
   read t >>= write r'

lemma swap_safe (ls : list $ sigma ref.{u}) :
  ∀ r r' : ref α, (sigma.mk _ r ∈ ls) → (sigma.mk _ r' ∈ ls) →
    mem_safety ls (swap r r') :=
begin
  intros, simp [swap,(>>=),(<$>),pure] with st,
  constructor, simpa, intros,
  constructor, intros,
  constructor, right, simpa, intros,
  constructor, right, simpa, intros,
  constructor, left, refl, intros,
  constructor, right, simpa, intros,
  constructor
end

def swap_if [decidable_linear_order α] (r r' : ref α) : st punit :=
do x ← read r,
   y ← read r',
   if y < x
     then swap r r'
     else pure punit.star

lemma swap_if_safe [decidable_linear_order α] (ls : list $ sigma ref.{u}) :
  ∀ r r' : ref α, (sigma.mk _ r ∈ ls) → (sigma.mk _ r' ∈ ls) →
    mem_safety ls (swap_if r r') :=
begin
  intros, simp [swap_if,(>>=),(<$>),pure] with st,
  constructor, assumption, intros,
  constructor, assumption, intros,
  split_ifs, apply swap_safe; assumption,
  constructor,
end

def sort_triple [decidable_linear_order α] (x y z : α) : st (α × α × α) :=
do rx ← new_ref x,
   ry ← new_ref y,
   rz ← new_ref z,
   swap_if rx ry,
   swap_if ry rz,
   swap_if rx ry,
   x' ← read rx, y' ← read ry, z' ← read rz,
   pure (x',y',z')

lemma sort_triple_safe [decidable_linear_order α] (ls : list $ sigma ref.{u}) :
  ∀ x y z : α,
    mem_safety ls (sort_triple x y z) :=
begin
  intros, simp [sort_triple,(>>=),(<$>),pure] with st,
  constructor, intros,
  constructor, intros,
  constructor, intros,
  refine mem_safety_bind _ _,
  apply swap_if_safe,
  { simp },
  { simp },
  intros,
  refine mem_safety_bind _ _,
  apply swap_if_safe,
  { apply a_3, simp },
  { apply a_3, simp },
  intros,
  refine mem_safety_bind _ _,
  apply swap_if_safe,
  { apply a_4, apply a_3, simp },
  { apply a_4, apply a_3, simp },
  intros,
  constructor, apply a_5, apply a_4, apply a_3, simp, intros,
  constructor, apply a_5, apply a_4, apply a_3, simp, intros,
  constructor, apply a_5, apply a_4, apply a_3, simp, intros,
  constructor,
end

#eval run (sort_triple 3 7 2) (sort_triple_safe _ _ _ _)

end st


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Scott Morrison
-/
import category_theory.currying
import category_theory.limits.over
import category_theory.limits.shapes.images
import category_theory.adjunction.reflective

/-!
# Monomorphisms over a fixed object

As preparation for defining `subobject X`, we set up the theory for
`mono_over X := {f : over X // mono f.hom}`.

Here `mono_over X` is a thin category (a pair of objects has at most one morphism between them),
so we can think of it as a preorder. However as it is not skeletal, it is not yet a partial order.

`subobject X` will be defined as the skeletalization of `mono_over X`.

We provide
* `def pullback [has_pullbacks C] (f : X ⟶ Y) : mono_over Y ⥤ mono_over X`
* `def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y`
* `def «exists» [has_images C] (f : X ⟶ Y) : mono_over X ⥤ mono_over Y`
and prove their basic properties and relationships.

## Notes

This development originally appeared in Bhavik Mehta's "Topos theory for Lean" repository,
and was ported to mathlib by Scott Morrison.

-/

universes v₁ v₂ u₁ u₂

noncomputable theory
namespace category_theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C] {X Y Z : C}
variables {D : Type u₂} [category.{v₂} D]

/--
The category of monomorphisms into `X` as a full subcategory of the over category.
This isn't skeletal, so it's not a partial order.

Later we define `subobject X` as the quotient of this by isomorphisms.
-/
@[derive [category]]
def mono_over (X : C) := {f : over X // mono f.hom}

namespace mono_over

/-- Construct a `mono_over X`. -/
@[simps]
def mk' {X A : C} (f : A ⟶ X) [hf : mono f] : mono_over X := { val := over.mk f, property := hf }

/-- The inclusion from monomorphisms over X to morphisms over X. -/
def forget (X : C) : mono_over X ⥤ over X := full_subcategory_inclusion _

instance : has_coe (mono_over X) C :=
{ coe := λ Y, Y.val.left, }

@[simp]
lemma forget_obj_left {f} : ((forget X).obj f).left = (f : C) := rfl

@[simp] lemma mk'_coe' {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f : C) = A := rfl

/-- Convenience notation for the underlying arrow of a monomorphism over X. -/
abbreviation arrow (f : mono_over X) : (f : C) ⟶ X := ((forget X).obj f).hom

@[simp] lemma mk'_arrow {X A : C} (f : A ⟶ X) [hf : mono f] : (mk' f).arrow = f := rfl

@[simp]
lemma forget_obj_hom {f} : ((forget X).obj f).hom = f.arrow := rfl

instance : full (forget X) := full_subcategory.full _
instance : faithful (forget X) := full_subcategory.faithful _

instance mono (f : mono_over X) : mono f.arrow := f.property

/-- The category of monomorphisms over X is a thin category,
which makes defining its skeleton easy. -/
instance is_thin {X : C} (f g : mono_over X) : subsingleton (f ⟶ g) :=
⟨begin
  intros h₁ h₂,
  ext1,
  erw [← cancel_mono g.arrow, over.w h₁, over.w h₂],
end⟩

@[reassoc] lemma w {f g : mono_over X} (k : f ⟶ g) : k.left ≫ g.arrow = f.arrow := over.w _

/-- Convenience constructor for a morphism in monomorphisms over `X`. -/
abbreviation hom_mk {f g : mono_over X} (h : f.val.left ⟶ g.val.left) (w : h ≫ g.arrow = f.arrow) :
  f ⟶ g :=
over.hom_mk h w

/-- Convenience constructor for an isomorphism in monomorphisms over `X`. -/
@[simps]
def iso_mk {f g : mono_over X} (h : f.val.left ≅ g.val.left) (w : h.hom ≫ g.arrow = f.arrow) :
  f ≅ g :=
{ hom := hom_mk h.hom w,
  inv := hom_mk h.inv (by rw [h.inv_comp_eq, w]) }

/-- If `f : mono_over X`, then `mk' f.arrow` is of course just `f`, but not definitionally, so we
    package it as an isomorphism. -/
@[simp] def mk'_arrow_iso {X : C} (f : mono_over X) : (mk' f.arrow) ≅ f :=
iso_mk (iso.refl _) (by simp)

/--
Lift a functor between over categories to a functor between `mono_over` categories,
given suitable evidence that morphisms are taken to monomorphisms.
-/
@[simps]
def lift {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  mono_over Y ⥤ mono_over X :=
{ obj := λ f, ⟨_, h f⟩,
  map := λ _ _ k, (mono_over.forget X).preimage ((mono_over.forget Y ⋙ F).map k), }

/--
Isomorphic functors `over Y ⥤ over X` lift to isomorphic functors `mono_over Y ⥤ mono_over X`.
-/
def lift_iso {Y : D} {F₁ F₂ : over Y ⥤ over X} (h₁ h₂) (i : F₁ ≅ F₂) :
  lift F₁ h₁ ≅ lift F₂ h₂ :=
fully_faithful_cancel_right (mono_over.forget X) (iso_whisker_left (mono_over.forget Y) i)

/-- `mono_over.lift` commutes with composition of functors. -/
def lift_comp {X Z : C} {Y : D} (F : over X ⥤ over Y) (G : over Y ⥤ over Z) (h₁ h₂) :
  lift F h₁ ⋙ lift G h₂ ≅ lift (F ⋙ G) (λ f, h₂ ⟨_, h₁ f⟩) :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

/-- `mono_over.lift` preserves the identity functor. -/
def lift_id :
  lift (𝟭 (over X)) (λ f, f.2) ≅ 𝟭 _ :=
fully_faithful_cancel_right (mono_over.forget _) (iso.refl _)

@[simp]
lemma lift_comm (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) :
  lift F h ⋙ mono_over.forget X = mono_over.forget Y ⋙ F :=
rfl

@[simp]
lemma lift_obj_arrow {Y : D} (F : over Y ⥤ over X)
  (h : ∀ (f : mono_over Y), mono (F.obj ((mono_over.forget Y).obj f)).hom) (f : mono_over Y) :
  ((lift F h).obj f).arrow = (F.obj ((forget Y).obj f)).hom :=
rfl

/--
Monomorphisms over an object `f : over A` in an over category
are equivalent to monomorphisms over the source of `f`.
-/
def slice {A : C} {f : over A} (h₁ h₂) : mono_over f ≌ mono_over f.left :=
{ functor := mono_over.lift f.iterated_slice_equiv.functor h₁,
  inverse := mono_over.lift f.iterated_slice_equiv.inverse h₂,
  unit_iso := mono_over.lift_id.symm ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.unit_iso ≪≫
    (mono_over.lift_comp _ _ _ _).symm,
  counit_iso := mono_over.lift_comp _ _ _ _ ≪≫
    mono_over.lift_iso _ _ f.iterated_slice_equiv.counit_iso ≪≫
    mono_over.lift_id }

section pullback
variables [has_pullbacks C]

/-- When `C` has pullbacks, a morphism `f : X ⟶ Y` induces a functor `mono_over Y ⥤ mono_over X`,
by pulling back a monomorphism along `f`. -/
def pullback (f : X ⟶ Y) : mono_over Y ⥤ mono_over X :=
mono_over.lift (over.pullback f)
begin
  intro g,
  apply @pullback.snd_of_mono _ _ _ _ _ _ _ _ _,
  change mono g.arrow,
  apply_instance,
end

/-- pullback commutes with composition (up to a natural isomorphism) -/
def pullback_comp (f : X ⟶ Y) (g : Y ⟶ Z) : pullback (f ≫ g) ≅ pullback g ⋙ pullback f :=
lift_iso _ _ (over.pullback_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- pullback preserves the identity (up to a natural isomorphism) -/
def pullback_id : pullback (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.pullback_id ≪≫ lift_id

@[simp] lemma pullback_obj_left (f : X ⟶ Y) (g : mono_over Y) :
  (((pullback f).obj g) : C) = limits.pullback g.arrow f :=
rfl

@[simp] lemma pullback_obj_arrow (f : X ⟶ Y) (g : mono_over Y) :
  ((pullback f).obj g).arrow = pullback.snd :=
rfl

end pullback

section map

attribute [instance] mono_comp

/--
We can map monomorphisms over `X` to monomorphisms over `Y`
by post-composition with a monomorphism `f : X ⟶ Y`.
-/
def map (f : X ⟶ Y) [mono f] : mono_over X ⥤ mono_over Y :=
lift (over.map f)
(λ g, by apply mono_comp g.arrow f)

/-- `mono_over.map` commutes with composition (up to a natural isomorphism). -/
def map_comp (f : X ⟶ Y) (g : Y ⟶ Z) [mono f] [mono g] :
  map (f ≫ g) ≅ map f ⋙ map g :=
lift_iso _ _ (over.map_comp _ _) ≪≫ (lift_comp _ _ _ _).symm

/-- `mono_over.map` preserves the identity (up to a natural isomorphism). -/
def map_id : map (𝟙 X) ≅ 𝟭 _ :=
lift_iso _ _ over.map_id ≪≫ lift_id

@[simp] lemma map_obj_left (f : X ⟶ Y) [mono f] (g : mono_over X) :
  (((map f).obj g) : C) = g.val.left :=
rfl

@[simp]
lemma map_obj_arrow (f : X ⟶ Y) [mono f] (g : mono_over X) :
  ((map f).obj g).arrow = g.arrow ≫ f :=
rfl

instance full_map (f : X ⟶ Y) [mono f] : full (map f) :=
{ preimage := λ g h e,
  begin
    refine hom_mk e.left _,
    rw [← cancel_mono f, assoc],
    apply w e,
  end }

instance faithful_map (f : X ⟶ Y) [mono f] : faithful (map f) := {}.

/--
Isomorphic objects have equivalent `mono_over` categories.
-/
@[simps] def map_iso {A B : C} (e : A ≅ B) : mono_over A ≌ mono_over B :=
{ functor := map e.hom,
  inverse := map e.inv,
  unit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id).symm,
  counit_iso := ((map_comp _ _).symm ≪≫ eq_to_iso (by simp) ≪≫ map_id) }

section
variables (X)

/-- An equivalence of categories `e` between `C` and `D` induces an equivalence between
    `mono_over X` and `mono_over (e.functor.obj X)` whenever `X` is an object of `C`. -/
@[simps] def congr (e : C ≌ D) : mono_over X ≌ mono_over (e.functor.obj X) :=
{ functor := lift (over.post e.functor) $ λ f, by { dsimp, apply_instance },
  inverse := (lift (over.post e.inverse) $ λ f, by { dsimp, apply_instance })
    ⋙ (map_iso (e.unit_iso.symm.app X)).functor,
  unit_iso := nat_iso.of_components (λ Y, iso_mk (e.unit_iso.app Y) (by tidy)) (by tidy),
  counit_iso := nat_iso.of_components (λ Y, iso_mk (e.counit_iso.app Y) (by tidy)) (by tidy) }

end

section
variable [has_pullbacks C]

/-- `map f` is left adjoint to `pullback f` when `f` is a monomorphism -/
def map_pullback_adj (f : X ⟶ Y) [mono f] : map f ⊣ pullback f :=
adjunction.restrict_fully_faithful
  (forget X) (forget Y) (over.map_pullback_adj f) (iso.refl _) (iso.refl _)

/-- `mono_over.map f` followed by `mono_over.pullback f` is the identity. -/
def pullback_map_self (f : X ⟶ Y) [mono f] :
  map f ⋙ pullback f ≅ 𝟭 _ :=
(as_iso (mono_over.map_pullback_adj f).unit).symm

end

end map

section image
variables (f : X ⟶ Y) [has_image f]

/--
The `mono_over Y` for the image inclusion for a morphism `f : X ⟶ Y`.
-/
def image_mono_over (f : X ⟶ Y) [has_image f] : mono_over Y := mono_over.mk' (image.ι f)

@[simp] lemma image_mono_over_arrow (f : X ⟶ Y) [has_image f] :
  (image_mono_over f).arrow = image.ι f :=
rfl

end image

section image

variables [has_images C]

/--
Taking the image of a morphism gives a functor `over X ⥤ mono_over X`.
-/
@[simps]
def image : over X ⥤ mono_over X :=
{ obj := λ f, image_mono_over f.hom,
  map := λ f g k,
  begin
    apply (forget X).preimage _,
    apply over.hom_mk _ _,
    refine image.lift {I := image _, m := image.ι g.hom, e := k.left ≫ factor_thru_image g.hom},
    apply image.lift_fac,
  end }

/--
`mono_over.image : over X ⥤ mono_over X` is left adjoint to
`mono_over.forget : mono_over X ⥤ over X`
-/
def image_forget_adj : image ⊣ forget X :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ f g,
  { to_fun := λ k,
    begin
      apply over.hom_mk (factor_thru_image f.hom ≫ k.left) _,
      change (factor_thru_image f.hom ≫ k.left) ≫ _ = f.hom,
      rw [assoc, over.w k],
      apply image.fac
    end,
    inv_fun := λ k,
    begin
      refine over.hom_mk _ _,
      refine image.lift {I := g.val.left, m := g.arrow, e := k.left, fac' := over.w k},
      apply image.lift_fac,
    end,
    left_inv := λ k, subsingleton.elim _ _,
    right_inv := λ k,
    begin
      ext1,
      change factor_thru_image _ ≫ image.lift _ = _,
      rw [← cancel_mono g.arrow, assoc, image.lift_fac, image.fac f.hom],
      exact (over.w k).symm,
    end } }

instance : is_right_adjoint (forget X) :=
{ left := image, adj := image_forget_adj }

instance reflective : reflective (forget X) := {}.

/--
Forgetting that a monomorphism over `X` is a monomorphism, then taking its image,
is the identity functor.
-/
def forget_image : forget X ⋙ image ≅ 𝟭 (mono_over X) :=
as_iso (adjunction.counit image_forget_adj)

end image

section «exists»
variables [has_images C]

/--
In the case where `f` is not a monomorphism but `C` has images,
we can still take the "forward map" under it, which agrees with `mono_over.map f`.
-/
def «exists» (f : X ⟶ Y) : mono_over X ⥤ mono_over Y :=
forget _ ⋙ over.map f ⋙ image

instance faithful_exists (f : X ⟶ Y) : faithful («exists» f) := {}.

/--
When `f : X ⟶ Y` is a monomorphism, `exists f` agrees with `map f`.
-/
def exists_iso_map (f : X ⟶ Y) [mono f] : «exists» f ≅ map f :=
nat_iso.of_components
begin
  intro Z,
  suffices : (forget _).obj ((«exists» f).obj Z) ≅ (forget _).obj ((map f).obj Z),
    apply preimage_iso this,
  apply over.iso_mk _ _,
  apply image_mono_iso_source (Z.arrow ≫ f),
  apply image_mono_iso_source_hom_self,
end
begin
  intros Z₁ Z₂ g,
  ext1,
  change image.lift ⟨_, _, _, _⟩ ≫ (image_mono_iso_source (Z₂.arrow ≫ f)).hom =
         (image_mono_iso_source (Z₁.arrow ≫ f)).hom ≫ g.left,
  rw [← cancel_mono (Z₂.arrow ≫ f), assoc, assoc, w_assoc g, image_mono_iso_source_hom_self,
      image_mono_iso_source_hom_self],
  apply image.lift_fac,
end

/-- `exists` is adjoint to `pullback` when images exist -/
def exists_pullback_adj (f : X ⟶ Y) [has_pullbacks C] : «exists» f ⊣ pullback f :=
adjunction.restrict_fully_faithful (forget X) (𝟭 _)
  ((over.map_pullback_adj f).comp _ _ image_forget_adj)
  (iso.refl _)
  (iso.refl _)

end «exists»

end mono_over

end category_theory


import justification common_meta property_catalogue.LTL
import pump1
open interactive S A

variable {α : Type}

set_option pp.structure_instances_qualifier true

def local_input_name : string := "pump1_input_1"
def local_strat_name : string := "pump1_strat_1"
def local_prf_name : string := "pump1_prf_1"

def preamble : string := "import justification pump1 common_meta property_catalogue.LTL \n open S A"

meta def proof_template (p₁ p₂ : string) : string :=
"\n\n
theorem " ++ local_prf_name ++ " : " ++ p₁ ++ " := \nbegin \n" ++ p₂ ++ "\nend" ++ "\n\n\n"

meta def evidence_file_template (ps : property_proof_data α) : string :=
preamble
++ "\n\n @[reducible] def " ++ local_input_name
++ " : property.input (path pump1) := "++ ps.input_string
++ "\n\n @[reducible] def "++ local_strat_name
++ " : Strategy (path pump1) := property.strategy " ++ local_input_name
++ proof_template ("deductive (path pump1) " ++ local_strat_name) (tscript_string ps.tscript)
++ ps.unused ++ hints_string ps.hints

meta def output (s : string) : io unit := do
  of ← io.mk_file_handle "src/evidence.lean" io.mode.write,
  io.fs.write of s.to_char_buffer

meta def driver (input : pexpr) : tactic unit :=
let α := path pump1 in
let ps : property_proof_data α := {} in
do
  STRAT ← tactic.to_expr input,
  match STRAT with
  | `(property.input.mk %%CLAIM %%PROPS) :=
  do
  inpt ← tactic.eval_expr (property.input α) STRAT,
  input_fmt ← tactic_format_expr STRAT,
  let input_s := input_fmt.to_string,
  let ps : property_proof_data α := { input := inpt,
              input_string := input_s,
              strat_expr := STRAT ,
              PROPS := PROPS,
              -- TODO : Clean this
              init_goal := `(deductive (path pump1) (property.strategy %%STRAT)),
              ..ps},
              -- And this
  let ps := ps.get_originals,
  let goal_str := "deductive (path pump1) " ++ local_strat_name,
  set_goal ps.init_goal,
  ps ← SOLVE (ps),
  str ← get_unused ps,
    match ps.solved with
    | tt := tactic.trace "True"
    | ff := tactic.trace "False"
    end,
    tactic.unsafe_run_io $ output $ evidence_file_template {unused := str ..ps}
| _ := return ()
end

@[user_command]
meta def main
(meta_info : decl_meta_info)
(_ : parse (lean.parser.tk "main")) : lean.parser unit :=
do
   F ← read "src/input/pumpExample1.txt" types.texpr,
   lean.parser.of_tactic $ driver F
.

main


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta
-/
import category_theory.limits.constructions.over.products
import category_theory.limits.constructions.over.connected
import category_theory.limits.constructions.limits_of_products_and_equalizers
import category_theory.limits.constructions.equalizers

/-!
# Limits in the over category

Declare instances for limits in the over category: If `C` has finite wide pullbacks, `over B` has
finite limits, and if `C` has arbitrary wide pullbacks then `over B` has limits.
-/
universes v u -- morphism levels before object levels. See note [category_theory universes].

open category_theory category_theory.limits

variables {J : Type v} [small_category J]
variables {C : Type u} [category.{v} C]
variable {X : C}

namespace category_theory.over

/-- Make sure we can derive pullbacks in `over B`. -/
example {B : C} [has_pullbacks C] : has_pullbacks (over B) := by apply_instance

/-- Make sure we can derive equalizers in `over B`. -/
example {B : C} [has_equalizers C] : has_equalizers (over B) := by apply_instance

instance has_finite_limits {B : C} [has_finite_wide_pullbacks C] : has_finite_limits (over B) :=
begin
  apply @finite_limits_from_equalizers_and_finite_products _ _ _ _,
  { exact construct_products.over_finite_products_of_finite_wide_pullbacks, },
  { apply @has_equalizers_of_pullbacks_and_binary_products _ _ _ _,
    { haveI : has_pullbacks C := ⟨by apply_instance⟩,
      exact construct_products.over_binary_product_of_pullback },
    { apply_instance, } }
end

instance has_limits {B : C} [has_wide_pullbacks C] : has_limits (over B) :=
begin
  apply @limits_from_equalizers_and_products _ _ _ _,
  { exact construct_products.over_products_of_wide_pullbacks },
  { apply @has_equalizers_of_pullbacks_and_binary_products _ _ _ _,
    { haveI : has_pullbacks C := ⟨by apply_instance⟩,
      exact construct_products.over_binary_product_of_pullback },
    { apply_instance, } }
end

end category_theory.over


/-
Copyright (c) 2017 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.Lean3Lib.data.buffer.parser
import Mathlib.tactic.doc_commands
import Mathlib.PostPort

namespace Mathlib

/--
`restate_axiom` takes a structure field, and makes a new, definitionally simplified copy of it.
If the existing field name ends with a `'`, the new field just has the prime removed. Otherwise,
we append `_lemma`.
The main application is to provide clean versions of structure fields that have been tagged with
an auto_param.
-/
/--
`restate_axiom` makes a new copy of a structure field, first definitionally simplifying the type.
This is useful to remove `auto_param` or `opt_param` from the statement.

As an example, we have:
```lean
structure A :=
(x : ℕ)
(a' : x = 1 . skip)

example (z : A) : z.x = 1 := by rw A.a' -- rewrite tactic failed, lemma is not an equality nor a iff

restate_axiom A.a'
example (z : A) : z.x = 1 := by rw A.a
```

By default, `restate_axiom` names the new lemma by removing a trailing `'`, or otherwise appending
`_lemma` if there is no trailing `'`. You can also give `restate_axiom` a second argument to
specify the new name, as in
```lean
restate_axiom A.a f
example (z : A) : z.x = 1 := by rw A.f
```
-/
end Mathlib


/-
Copyright (c) 2020 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.geometry.manifold.smooth_manifold_with_corners
import Mathlib.PostPort

universes u_1 u_3 l u_2 u_4

namespace Mathlib

/-!
# Local properties invariant under a groupoid

We study properties of a triple `(g, s, x)` where `g` is a function between two spaces `H` and `H'`,
`s` is a subset of `H` and `x` is a point of `H`. Our goal is to register how such a property
should behave to make sense in charted spaces modelled on `H` and `H'`.

The main examples we have in mind are the properties "`g` is differentiable at `x` within `s`", or
"`g` is smooth at `x` within `s`". We want to develop general results that, when applied in these
specific situations, say that the notion of smooth function in a manifold behaves well under
restriction, intersection, is local, and so on.

## Main definitions

* `local_invariant_prop G G' P` says that a property `P` of a triple `(g, s, x)` is local, and
  invariant under composition by elements of the groupoids `G` and `G'` of `H` and `H'`
  respectively.
* `charted_space.lift_prop_within_at` (resp. `lift_prop_at`, `lift_prop_on` and `lift_prop`):
  given a property `P` of `(g, s, x)` where `g : H → H'`, define the corresponding property
  for functions `M → M'` where `M` and `M'` are charted spaces modelled respectively on `H` and
  `H'`. We define these properties within a set at a point, or at a point, or on a set, or in the
  whole space. This lifting process (obtained by restricting to suitable chart domains) can always
  be done, but it only behaves well under locality and invariance assumptions.

Given `hG : local_invariant_prop G G' P`, we deduce many properties of the lifted property on the
charted spaces. For instance, `hG.lift_prop_within_at_inter` says that `P g s x` is equivalent to
`P g (s ∩ t) x` whenever `t` is a neighborhood of `x`.

## Implementation notes

We do not use dot notation for properties of the lifted property. For instance, we have
`hG.lift_prop_within_at_congr` saying that if `lift_prop_within_at P g s x` holds, and `g` and `g'`
coincide on `s`, then `lift_prop_within_at P g' s x` holds. We can't call it
`lift_prop_within_at.congr` as it is in the namespace associated to `local_invariant_prop`, not
in the one for `lift_prop_within_at`.
-/

namespace structure_groupoid

/-- Structure recording good behavior of a property of a triple `(f, s, x)` where `f` is a function,
`s` a set and `x` a point. Good behavior here means locality and invariance under given groupoids
(both in the source and in the target). Given such a good behavior, the lift of this property
to charted spaces admitting these groupoids will inherit the good behavior. -/
structure local_invariant_prop {H : Type u_1} [topological_space H] {H' : Type u_3} [topological_space H'] (G : structure_groupoid H) (G' : structure_groupoid H') (P : (H → H') → set H → H → Prop)
where
  is_local : ∀ {s : set H} {x : H} {u : set H} {f : H → H'}, is_open u → x ∈ u → (P f s x ↔ P f (s ∩ u) x)
  right_invariance : ∀ {s : set H} {x : H} {f : H → H'} {e : local_homeomorph H H},
  e ∈ G →
    x ∈ local_equiv.source (local_homeomorph.to_local_equiv e) →
      P f s x →
        P (f ∘ ⇑(local_homeomorph.symm e))
          (local_equiv.target (local_homeomorph.to_local_equiv e) ∩ ⇑(local_homeomorph.symm e) ⁻¹' s) (coe_fn e x)
  congr : ∀ {s : set H} {x : H} {f g : H → H'}, (∀ (y : H), y ∈ s → f y = g y) → f x = g x → P f s x → P g s x
  left_invariance : ∀ {s : set H} {x : H} {f : H → H'} {e' : local_homeomorph H' H'},
  e' ∈ G' →
    s ⊆ f ⁻¹' local_equiv.source (local_homeomorph.to_local_equiv e') →
      f x ∈ local_equiv.source (local_homeomorph.to_local_equiv e') → P f s x → P (⇑e' ∘ f) s x

end structure_groupoid

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property in a charted space, by requiring that it holds at the preferred chart at
this point. (When the property is local and invariant, it will in fact hold using any chart, see
`lift_prop_within_at_indep_chart`). We require continuity in the lifted property, as otherwise one
single chart might fail to capture the behavior of the function.
-/
def charted_space.lift_prop_within_at {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] (P : (H → H') → set H → H → Prop) (f : M → M') (s : set M) (x : M) :=
  continuous_within_at f s x ∧
    P (⇑(charted_space.chart_at H' (f x)) ∘ f ∘ ⇑(local_homeomorph.symm (charted_space.chart_at H x)))
      (local_equiv.target (local_homeomorph.to_local_equiv (charted_space.chart_at H x)) ∩
        ⇑(local_homeomorph.symm (charted_space.chart_at H x)) ⁻¹'
          (s ∩ f ⁻¹' local_equiv.source (local_homeomorph.to_local_equiv (charted_space.chart_at H' (f x)))))
      (coe_fn (charted_space.chart_at H x) x)

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of functions on sets in a charted space, by requiring that it holds
around each point of the set, in the preferred charts. -/
def charted_space.lift_prop_on {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] (P : (H → H') → set H → H → Prop) (f : M → M') (s : set M) :=
  ∀ (x : M), x ∈ s → charted_space.lift_prop_within_at P f s x

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of a function at a point in a charted space, by requiring that it holds
in the preferred chart. -/
def charted_space.lift_prop_at {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] (P : (H → H') → set H → H → Prop) (f : M → M') (x : M) :=
  charted_space.lift_prop_within_at P f set.univ x

/-- Given a property of germs of functions and sets in the model space, then one defines
a corresponding property of a function in a charted space, by requiring that it holds
in the preferred chart around every point. -/
def charted_space.lift_prop {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] (P : (H → H') → set H → H → Prop) (f : M → M') :=
  ∀ (x : M), charted_space.lift_prop_at P f x

namespace structure_groupoid

theorem lift_prop_within_at_univ {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {P : (H → H') → set H → H → Prop} {g : M → M'} {x : M} : charted_space.lift_prop_within_at P g set.univ x ↔ charted_space.lift_prop_at P g x :=
  iff.rfl

theorem lift_prop_on_univ {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {P : (H → H') → set H → H → Prop} {g : M → M'} : charted_space.lift_prop_on P g set.univ ↔ charted_space.lift_prop P g := sorry

namespace local_invariant_prop

/-- If a property of a germ of function `g` on a pointed set `(s, x)` is invariant under the
structure groupoid (by composition in the source space and in the target space), then
expressing it in charted spaces does not depend on the element of the maximal atlas one uses
both in the source and in the target manifolds, provided they are defined around `x` and `g x`
respectively, and provided `g` is continuous within `s` at `x` (otherwise, the local behavior
of `g` at `x` can not be captured with a chart in the target). -/
theorem lift_prop_within_at_indep_chart_aux {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {e : local_homeomorph M H} {e' : local_homeomorph M H} {f : local_homeomorph M' H'} {f' : local_homeomorph M' H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) (he : e ∈ maximal_atlas M G) (xe : x ∈ local_equiv.source (local_homeomorph.to_local_equiv e)) (he' : e' ∈ maximal_atlas M G) (xe' : x ∈ local_equiv.source (local_homeomorph.to_local_equiv e')) (hf : f ∈ maximal_atlas M' G') (xf : g x ∈ local_equiv.source (local_homeomorph.to_local_equiv f)) (hf' : f' ∈ maximal_atlas M' G') (xf' : g x ∈ local_equiv.source (local_homeomorph.to_local_equiv f')) (hgs : continuous_within_at g s x) (h : P (⇑f ∘ g ∘ ⇑(local_homeomorph.symm e))
  (local_equiv.target (local_homeomorph.to_local_equiv e) ∩
    ⇑(local_homeomorph.symm e) ⁻¹' (s ∩ g ⁻¹' local_equiv.source (local_homeomorph.to_local_equiv f)))
  (coe_fn e x)) : P (⇑f' ∘ g ∘ ⇑(local_homeomorph.symm e'))
  (local_equiv.target (local_homeomorph.to_local_equiv e') ∩
    ⇑(local_homeomorph.symm e') ⁻¹' (s ∩ g ⁻¹' local_equiv.source (local_homeomorph.to_local_equiv f')))
  (coe_fn e' x) := sorry

theorem lift_prop_within_at_indep_chart {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {e : local_homeomorph M H} {f : local_homeomorph M' H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) [has_groupoid M G] [has_groupoid M' G'] (he : e ∈ maximal_atlas M G) (xe : x ∈ local_equiv.source (local_homeomorph.to_local_equiv e)) (hf : f ∈ maximal_atlas M' G') (xf : g x ∈ local_equiv.source (local_homeomorph.to_local_equiv f)) : charted_space.lift_prop_within_at P g s x ↔
  continuous_within_at g s x ∧
    P (⇑f ∘ g ∘ ⇑(local_homeomorph.symm e))
      (local_equiv.target (local_homeomorph.to_local_equiv e) ∩
        ⇑(local_homeomorph.symm e) ⁻¹' (s ∩ g ⁻¹' local_equiv.source (local_homeomorph.to_local_equiv f)))
      (coe_fn e x) := sorry

theorem lift_prop_on_indep_chart {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {e : local_homeomorph M H} {f : local_homeomorph M' H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} (hG : local_invariant_prop G G' P) [has_groupoid M G] [has_groupoid M' G'] (he : e ∈ maximal_atlas M G) (hf : f ∈ maximal_atlas M' G') (h : charted_space.lift_prop_on P g s) (y : H) : y ∈
    local_equiv.target (local_homeomorph.to_local_equiv e) ∩
      ⇑(local_homeomorph.symm e) ⁻¹' (s ∩ g ⁻¹' local_equiv.source (local_homeomorph.to_local_equiv f)) →
  P (⇑f ∘ g ∘ ⇑(local_homeomorph.symm e))
    (local_equiv.target (local_homeomorph.to_local_equiv e) ∩
      ⇑(local_homeomorph.symm e) ⁻¹' (s ∩ g ⁻¹' local_equiv.source (local_homeomorph.to_local_equiv f)))
    y := sorry

theorem lift_prop_within_at_inter' {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {t : set M} {x : M} (hG : local_invariant_prop G G' P) (ht : t ∈ nhds_within x s) : charted_space.lift_prop_within_at P g (s ∩ t) x ↔ charted_space.lift_prop_within_at P g s x := sorry

theorem lift_prop_within_at_inter {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {t : set M} {x : M} (hG : local_invariant_prop G G' P) (ht : t ∈ nhds x) : charted_space.lift_prop_within_at P g (s ∩ t) x ↔ charted_space.lift_prop_within_at P g s x :=
  lift_prop_within_at_inter' hG (mem_nhds_within_of_mem_nhds ht)

theorem lift_prop_at_of_lift_prop_within_at {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) (h : charted_space.lift_prop_within_at P g s x) (hs : s ∈ nhds x) : charted_space.lift_prop_at P g x := sorry

theorem lift_prop_within_at_of_lift_prop_at_of_mem_nhds {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) (h : charted_space.lift_prop_at P g x) (hs : s ∈ nhds x) : charted_space.lift_prop_within_at P g s x := sorry

theorem lift_prop_on_of_locally_lift_prop_on {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} (hG : local_invariant_prop G G' P) (h : ∀ (x : M), x ∈ s → ∃ (u : set M), is_open u ∧ x ∈ u ∧ charted_space.lift_prop_on P g (s ∩ u)) : charted_space.lift_prop_on P g s := sorry

theorem lift_prop_of_locally_lift_prop_on {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} (hG : local_invariant_prop G G' P) (h : ∀ (x : M), ∃ (u : set M), is_open u ∧ x ∈ u ∧ charted_space.lift_prop_on P g u) : charted_space.lift_prop P g := sorry

theorem lift_prop_within_at_congr {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) (h : charted_space.lift_prop_within_at P g s x) (h₁ : ∀ (y : M), y ∈ s → g' y = g y) (hx : g' x = g x) : charted_space.lift_prop_within_at P g' s x := sorry

theorem lift_prop_within_at_congr_iff {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) (h₁ : ∀ (y : M), y ∈ s → g' y = g y) (hx : g' x = g x) : charted_space.lift_prop_within_at P g' s x ↔ charted_space.lift_prop_within_at P g s x := sorry

theorem lift_prop_within_at_congr_of_eventually_eq {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) (h : charted_space.lift_prop_within_at P g s x) (h₁ : filter.eventually_eq (nhds_within x s) g' g) (hx : g' x = g x) : charted_space.lift_prop_within_at P g' s x := sorry

theorem lift_prop_within_at_congr_iff_of_eventually_eq {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {s : set M} {x : M} (hG : local_invariant_prop G G' P) (h₁ : filter.eventually_eq (nhds_within x s) g' g) (hx : g' x = g x) : charted_space.lift_prop_within_at P g' s x ↔ charted_space.lift_prop_within_at P g s x := sorry

theorem lift_prop_at_congr_of_eventually_eq {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {x : M} (hG : local_invariant_prop G G' P) (h : charted_space.lift_prop_at P g x) (h₁ : filter.eventually_eq (nhds x) g' g) : charted_space.lift_prop_at P g' x := sorry

theorem lift_prop_at_congr_iff_of_eventually_eq {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {x : M} (hG : local_invariant_prop G G' P) (h₁ : filter.eventually_eq (nhds x) g' g) : charted_space.lift_prop_at P g' x ↔ charted_space.lift_prop_at P g x := sorry

theorem lift_prop_on_congr {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {s : set M} (hG : local_invariant_prop G G' P) (h : charted_space.lift_prop_on P g s) (h₁ : ∀ (y : M), y ∈ s → g' y = g y) : charted_space.lift_prop_on P g' s :=
  fun (x : M) (hx : x ∈ s) => lift_prop_within_at_congr hG (h x hx) h₁ (h₁ x hx)

theorem lift_prop_on_congr_iff {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {G : structure_groupoid H} {G' : structure_groupoid H'} {P : (H → H') → set H → H → Prop} {g : M → M'} {g' : M → M'} {s : set M} (hG : local_invariant_prop G G' P) (h₁ : ∀ (y : M), y ∈ s → g' y = g y) : charted_space.lift_prop_on P g' s ↔ charted_space.lift_prop_on P g s := sorry

theorem lift_prop_within_at_mono {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {t : set M} {x : M} (mono : ∀ {s : set H} {x : H} {t : set H} {f : H → H'}, t ⊆ s → P f s x → P f t x) (h : charted_space.lift_prop_within_at P g t x) (hst : s ⊆ t) : charted_space.lift_prop_within_at P g s x := sorry

theorem lift_prop_within_at_of_lift_prop_at {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {x : M} (mono : ∀ {s : set H} {x : H} {t : set H} {f : H → H'}, t ⊆ s → P f s x → P f t x) (h : charted_space.lift_prop_at P g x) : charted_space.lift_prop_within_at P g s x :=
  lift_prop_within_at_mono mono
    (eq.mp (Eq._oldrec (Eq.refl (charted_space.lift_prop_at P g x)) (Eq.symm (propext lift_prop_within_at_univ))) h)
    (set.subset_univ s)

theorem lift_prop_on_mono {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} {t : set M} (mono : ∀ {s : set H} {x : H} {t : set H} {f : H → H'}, t ⊆ s → P f s x → P f t x) (h : charted_space.lift_prop_on P g t) (hst : s ⊆ t) : charted_space.lift_prop_on P g s :=
  fun (x : M) (hx : x ∈ s) => lift_prop_within_at_mono mono (h x (hst hx)) hst

theorem lift_prop_on_of_lift_prop {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {H' : Type u_3} {M' : Type u_4} [topological_space H'] [topological_space M'] [charted_space H' M'] {P : (H → H') → set H → H → Prop} {g : M → M'} {s : set M} (mono : ∀ {s : set H} {x : H} {t : set H} {f : H → H'}, t ⊆ s → P f s x → P f t x) (h : charted_space.lift_prop P g) : charted_space.lift_prop_on P g s :=
  lift_prop_on_mono mono
    (eq.mp (Eq._oldrec (Eq.refl (charted_space.lift_prop P g)) (Eq.symm (propext lift_prop_on_univ))) h)
    (set.subset_univ s)

theorem lift_prop_at_of_mem_maximal_atlas {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {e : local_homeomorph M H} {x : M} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) (he : e ∈ maximal_atlas M G) (hx : x ∈ local_equiv.source (local_homeomorph.to_local_equiv e)) : charted_space.lift_prop_at Q (⇑e) x := sorry

theorem lift_prop_on_of_mem_maximal_atlas {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {e : local_homeomorph M H} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) (he : e ∈ maximal_atlas M G) : charted_space.lift_prop_on Q (⇑e) (local_equiv.source (local_homeomorph.to_local_equiv e)) := sorry

theorem lift_prop_at_symm_of_mem_maximal_atlas {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {e : local_homeomorph M H} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] {x : H} (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) (he : e ∈ maximal_atlas M G) (hx : x ∈ local_equiv.target (local_homeomorph.to_local_equiv e)) : charted_space.lift_prop_at Q (⇑(local_homeomorph.symm e)) x := sorry

theorem lift_prop_on_symm_of_mem_maximal_atlas {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {e : local_homeomorph M H} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) (he : e ∈ maximal_atlas M G) : charted_space.lift_prop_on Q (⇑(local_homeomorph.symm e)) (local_equiv.target (local_homeomorph.to_local_equiv e)) := sorry

theorem lift_prop_at_chart {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {x : M} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) : charted_space.lift_prop_at Q (⇑(charted_space.chart_at H x)) x :=
  lift_prop_at_of_mem_maximal_atlas hG hQ (chart_mem_maximal_atlas G x) (charted_space.mem_chart_source H x)

theorem lift_prop_on_chart {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {x : M} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) : charted_space.lift_prop_on Q (⇑(charted_space.chart_at H x))
  (local_equiv.source (local_homeomorph.to_local_equiv (charted_space.chart_at H x))) :=
  lift_prop_on_of_mem_maximal_atlas hG hQ (chart_mem_maximal_atlas G x)

theorem lift_prop_at_chart_symm {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {x : M} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) : charted_space.lift_prop_at Q (⇑(local_homeomorph.symm (charted_space.chart_at H x)))
  (coe_fn (charted_space.chart_at H x) x) := sorry

theorem lift_prop_on_chart_symm {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {x : M} {Q : (H → H) → set H → H → Prop} [has_groupoid M G] (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) : charted_space.lift_prop_on Q (⇑(local_homeomorph.symm (charted_space.chart_at H x)))
  (local_equiv.target (local_homeomorph.to_local_equiv (charted_space.chart_at H x))) :=
  lift_prop_on_symm_of_mem_maximal_atlas hG hQ (chart_mem_maximal_atlas G x)

theorem lift_prop_id {H : Type u_1} {M : Type u_2} [topological_space H] [topological_space M] [charted_space H M] {G : structure_groupoid H} {Q : (H → H) → set H → H → Prop} (hG : local_invariant_prop G G Q) (hQ : ∀ (y : H), Q id set.univ y) : charted_space.lift_prop Q id := sorry

end local_invariant_prop

/-- A function from a model space `H` to itself is a local structomorphism, with respect to a
structure groupoid `G` for `H`, relative to a set `s` in `H`, if for all points `x` in the set, the
function agrees with a `G`-structomorphism on `s` in a neighbourhood of `x`. -/
def is_local_structomorph_within_at {H : Type u_1} [topological_space H] (G : structure_groupoid H) (f : H → H) (s : set H) (x : H) :=
  x ∈ s →
    ∃ (e : local_homeomorph H H),
      e ∈ G ∧
        set.eq_on f (local_equiv.to_fun (local_homeomorph.to_local_equiv e))
            (s ∩ local_equiv.source (local_homeomorph.to_local_equiv e)) ∧
          x ∈ local_equiv.source (local_homeomorph.to_local_equiv e)

/-- For a groupoid `G` which is `closed_under_restriction`, being a local structomorphism is a local
invariant property. -/
theorem is_local_structomorph_within_at_local_invariant_prop {H : Type u_1} [topological_space H] (G : structure_groupoid H) [closed_under_restriction G] : local_invariant_prop G G (is_local_structomorph_within_at G) := sorry


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.bool.default

namespace Mathlib

/-
Simplification lemmas for ite.

We don't prove them at logic.lean because it is easier to prove them using
the tactic framework.
-/

@[simp] theorem if_true_right_eq_or (p : Prop) [h : Decidable p] (q : Prop) :
    ite p q True = (¬p ∨ q) :=
  sorry

@[simp] theorem if_true_left_eq_or (p : Prop) [h : Decidable p] (q : Prop) :
    ite p True q = (p ∨ q) :=
  sorry

@[simp] theorem if_false_right_eq_and (p : Prop) [h : Decidable p] (q : Prop) :
    ite p q False = (p ∧ q) :=
  sorry

@[simp] theorem if_false_left_eq_and (p : Prop) [h : Decidable p] (q : Prop) :
    ite p False q = (¬p ∧ q) :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.AppBuilder

namespace Lean.Meta

inductive CongrArgKind where
  | /-- It is a parameter for the congruence theorem, the parameter occurs in the left and right hand sides. -/
    fixed
  | /--
      It is not a parameter for the congruence theorem, the theorem was specialized for this parameter.
      This only happens if the parameter is a subsingleton/proposition, and other parameters depend on it. -/
    fixedNoParam
  | /--
      The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `eq_i : a_i = b_i`.
      `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their equality. -/
    eq
  | /--
      The congr-simp theorems contains only one parameter for this kind of argument, and congr theorems contains two.
      They correspond to arguments that are subsingletons/propositions. -/
    cast
  | /--
     The lemma contains three parameters for this kind of argument `a_i`, `b_i` and `eq_i : HEq a_i b_i`.
     `a_i` and `b_i` represent the left and right hand sides, and `eq_i` is a proof for their heterogeneous equality. -/
    heq
  | /--
     For congr-simp theorems only.  Indicates a decidable instance argument.
     The lemma contains two arguments [a_i : Decidable ...] [b_i : Decidable ...] -/
    subsingletonInst
  deriving Inhabited

structure CongrTheorem where
  type     : Expr
  proof    : Expr
  argKinds : Array CongrArgKind

private def addPrimeToFVarUserNames (ys : Array Expr) (lctx : LocalContext) : LocalContext := Id.run <| do
  let mut lctx := lctx
  for y in ys do
    let decl := lctx.getFVar! y
    lctx := lctx.setUserName decl.fvarId (decl.userName.appendAfter "'")
  return lctx

private def setBinderInfosD (ys : Array Expr) (lctx : LocalContext) : LocalContext := Id.run <| do
  let mut lctx := lctx
  for y in ys do
    let decl := lctx.getFVar! y
    lctx := lctx.setBinderInfo decl.fvarId BinderInfo.default
  return lctx

partial def mkHCongrWithArity (f : Expr) (numArgs : Nat) : MetaM CongrTheorem := do
  let fType ← inferType f
  forallBoundedTelescope fType numArgs fun xs xType =>
  forallBoundedTelescope fType numArgs fun ys yType => do
    if xs.size != numArgs then
      throwError "failed to generate hcongr theorem, insufficient number of arguments"
    else
      let lctx := addPrimeToFVarUserNames ys (← getLCtx) |> setBinderInfosD ys |> setBinderInfosD xs
      withLCtx lctx (← getLocalInstances) do
      withNewEqs xs ys fun eqs argKinds => do
        let mut hs := #[]
        for x in xs, y in ys, eq in eqs do
          hs := hs.push x |>.push y |>.push eq
        let xType := xType.consumeAutoOptParam
        let yType := yType.consumeAutoOptParam
        let resultType ← if xType == yType then mkEq xType yType else mkHEq xType yType
        let congrType ← mkForallFVars hs resultType
        return {
          type  := congrType
          proof := (← mkProof congrType)
          argKinds
        }
where
  withNewEqs {α} (xs ys : Array Expr) (k : Array Expr → Array CongrArgKind → MetaM α) : MetaM α :=
    let rec loop (i : Nat) (eqs : Array Expr) (kinds : Array CongrArgKind) := do
      if  i < xs.size then
        let x := xs[i]
        let y := ys[i]
        let xType := (← inferType x).consumeAutoOptParam
        let yType := (← inferType y).consumeAutoOptParam
        if xType == yType then
          withLocalDeclD ((`e).appendIndexAfter (i+1)) (← mkEq x y) fun h =>
            loop (i+1) (eqs.push h) (kinds.push CongrArgKind.eq)
        else
          withLocalDeclD ((`e).appendIndexAfter (i+1)) (← mkHEq x y) fun h =>
            loop (i+1) (eqs.push h) (kinds.push CongrArgKind.heq)
      else
        k eqs kinds
    loop 0 #[] #[]

  mkProof (type : Expr) : MetaM Expr := do
    if let some (_, lhs, _) := type.eq? then
      mkEqRefl lhs
    else if let some (_, lhs, _, _) := type.heq? then
      mkHEqRefl lhs
    else
      forallBoundedTelescope type (some 1) fun a type =>
      let a := a[0]
      forallBoundedTelescope type (some 1) fun b motive =>
      let b := b[0]
      let type := type.bindingBody!.instantiate1 a
      withLocalDeclD motive.bindingName! motive.bindingDomain! fun eqPr => do
      let type := type.bindingBody!
      let motive := motive.bindingBody!
      let minor ← mkProof type
      let mut major := eqPr
      if (← whnf (← inferType eqPr)).isHEq then
        major ← mkEqOfHEq major
      let motive ← mkLambdaFVars #[b] motive
      mkLambdaFVars #[a, b, eqPr] (← mkEqNDRec motive minor major)

def mkHCongr (f : Expr) : MetaM CongrTheorem := do
  mkHCongrWithArity f (← getFunInfo f).getArity

/--
  Ensure that all dependencies for `congr_arg_kind::Eq` are `congr_arg_kind::Fixed`.
-/
private def fixKindsForDependencies (info : FunInfo) (kinds : Array CongrArgKind) : Array CongrArgKind := Id.run do
  let mut kinds := kinds
  for i in [:info.paramInfo.size] do
    for j in [i+1:info.paramInfo.size] do
      if info.paramInfo[j].backDeps.contains i then
        if kinds[j] matches CongrArgKind.eq || kinds[j] matches CongrArgKind.fixed then
          -- We must fix `i` because there is a `j` that depends on `i` and `j` is not cast-fixed.
          kinds := kinds.set! i CongrArgKind.fixed
          break
  return kinds

/--
  (Try to) cast expression `e` to the given type using the equations `eqs`.
  `deps` contains the indices of the relevant equalities.
  Remark: deps is sorted. -/
private partial def mkCast (e : Expr) (type : Expr) (deps : Array Nat) (eqs : Array (Option Expr)) : MetaM Expr := do
  let rec go (i : Nat) (type : Expr) : MetaM Expr := do
     if i < deps.size then
       match eqs[deps[i]] with
       | none => go (i+1) type
       | some major =>
         let some (_, lhs, rhs) := (← inferType major).eq? | unreachable!
         if (← dependsOn type major.fvarId!) then
           let motive ← mkLambdaFVars #[rhs, major] type
           let typeNew := type.replaceFVar rhs lhs |>.replaceFVar major (← mkEqRefl lhs)
           let minor ← go (i+1) typeNew
           mkEqRec motive minor major
         else
           let motive ← mkLambdaFVars #[rhs] type
           let typeNew := type.replaceFVar rhs lhs
           let minor ← go (i+1) typeNew
           mkEqNDRec motive minor major
     else
       return e
  go 0 type

private def hasCastLike (kinds : Array CongrArgKind) : Bool :=
  kinds.any fun kind => kind matches CongrArgKind.cast || kind matches CongrArgKind.subsingletonInst

private def withNext (type : Expr) (k : Expr → Expr → MetaM α) : MetaM α := do
  forallBoundedTelescope type (some 1) fun xs type => k xs[0] type

/--
  Create a congruence theorem that is useful for the simplifier.
-/
partial def mkCongrSimpWithArity? (f : Expr) (numArgs : Nat) : MetaM (Option CongrTheorem) := do
  let info ← getFunInfo f
  let kinds := getKinds info
  if let some result ← mk? f info kinds then
    return some result
  else if hasCastLike kinds then
    -- Simplify kinds and try again
    let kinds := kinds.map fun kind =>
      if kind matches CongrArgKind.cast || kind matches CongrArgKind.subsingletonInst then CongrArgKind.fixed else kind
    mk? f info kinds
  else
    return none
where
  /--
    Create a congruence theorem that is useful for the simplifier.
    In this kind of theorem, if the i-th argument is a `cast` argument, then the theorem
    contains an input `a_i` representing the i-th argument in the left-hand-side, and
    it appears with a cast (e.g., `Eq.drec ... a_i ...`) in the right-hand-side.
    The idea is that the right-hand-side of this theorem "tells" the simplifier
    how the resulting term looks like. -/
  mk? (f : Expr) (info : FunInfo) (kinds : Array CongrArgKind) : MetaM (Option CongrTheorem) := do
    try
      let fType ← inferType f
      forallBoundedTelescope fType kinds.size fun lhss xType => do
        if lhss.size != kinds.size then return none
        let rec go (i : Nat) (rhss : Array Expr) (eqs : Array (Option Expr)) (hyps : Array Expr) : MetaM CongrTheorem := do
          if i == kinds.size then
            let lhs := mkAppN f lhss
            let rhs := mkAppN f rhss
            let type ← mkForallFVars hyps (← mkEq lhs rhs)
            let proof ← mkProof type kinds
            return { type, proof, argKinds := kinds }
          else
            let hyps := hyps.push lhss[i]
            match kinds[i] with
            | CongrArgKind.heq => unreachable!
            | CongrArgKind.fixedNoParam => unreachable!
            | CongrArgKind.eq =>
              let localDecl ← getLocalDecl lhss[i].fvarId!
              withLocalDecl localDecl.userName localDecl.binderInfo localDecl.type fun rhs => do
              withLocalDeclD ((`e).appendIndexAfter (eqs.size+1)) (← mkEq lhss[i] rhs) fun eq => do
                go (i+1) (rhss.push rhs) (eqs.push eq) (hyps.push rhs |>.push eq)
            | CongrArgKind.fixed => go (i+1) (rhss.push lhss[i]) (eqs.push none) hyps
            | CongrArgKind.cast =>
              let rhsType := (← inferType lhss[i]).replaceFVars (lhss[:rhss.size]) rhss
              let rhs ← mkCast lhss[i] rhsType info.paramInfo[i].backDeps eqs
              go (i+1) (rhss.push rhs) (eqs.push none) hyps
            | CongrArgKind.subsingletonInst =>
              let rhsType := (← inferType lhss[i]).replaceFVars (lhss[:rhss.size]) rhss
              withLocalDecl (← getLocalDecl lhss[i].fvarId!).userName BinderInfo.instImplicit rhsType fun rhs =>
                go (i+1) (rhss.push rhs) (eqs.push none) (hyps.push rhs)
        return some (← go 0 #[] #[] #[])
    catch _ =>
      return none

  mkProof (type : Expr) (kinds : Array CongrArgKind) : MetaM Expr := do
    let rec go (i : Nat) (type : Expr) : MetaM Expr := do
      if i == kinds.size then
        let some (_, lhs, _) := type.eq? | unreachable!
        mkEqRefl lhs
      else
        withNext type fun lhs type => do
        match kinds[i] with
        | CongrArgKind.heq => unreachable!
        | CongrArgKind.fixedNoParam => unreachable!
        | CongrArgKind.fixed => mkLambdaFVars #[lhs] (← go (i+1) type)
        | CongrArgKind.cast => mkLambdaFVars #[lhs] (← go (i+1) type)
        | CongrArgKind.eq =>
          let typeSub := type.bindingBody!.bindingBody!.instantiate #[(← mkEqRefl lhs), lhs]
          withNext type fun rhs type =>
          withNext type fun heq type => do
            let motive ← mkLambdaFVars #[rhs, heq] type
            let proofSub ← go (i+1) typeSub
            mkLambdaFVars #[lhs, rhs, heq] (← mkEqRec motive proofSub heq)
        | CongrArgKind.subsingletonInst =>
          let typeSub := type.bindingBody!.instantiate #[lhs]
          withNext type fun rhs type => do
            let motive ← mkLambdaFVars #[rhs] type
            let proofSub ← go (i+1) typeSub
            let heq ← mkAppM ``Subsingleton.elim #[lhs, rhs]
            mkLambdaFVars #[lhs, rhs] (← mkEqNDRec motive proofSub heq)
     go 0 type

  getKinds (info : FunInfo) : Array CongrArgKind := Id.run do
    /- The default `CongrArgKind` is `eq`, which allows `simp` to rewrite this
       argument. However, if there are references from `i` to `j`, we cannot
       rewrite both `i` and `j`. So we must change the `CongrArgKind` at
       either `i` or `j`. In principle, if there is a dependency with `i`
       appearing after `j`, then we set `j` to `fixed` (or `cast`). But there is
       an optimization: if `i` is a subsingleton, we can fix it instead of
       `j`, since all subsingletons are equal anyway. The fixing happens in
        two loops: one for the special cases, and one for the general case. -/
    let mut result := #[]
    for i in [:info.paramInfo.size] do
      if info.resultDeps.contains i then
        result := result.push CongrArgKind.fixed
      else if info.paramInfo[i].isProp then
        result := result.push CongrArgKind.cast
      else if info.paramInfo[i].isInstImplicit then
        if shouldUseSubsingletonInst info result i then
          result := result.push CongrArgKind.subsingletonInst
        else
          result := result.push CongrArgKind.fixed
      else
        result := result.push CongrArgKind.eq
    return fixKindsForDependencies info result

  /--
    Test whether we should use `subsingletonInst` kind for instances which depend on `eq`.
    (Otherwise `fixKindsForDependencies`will downgrade them to Fixed -/
  shouldUseSubsingletonInst (info : FunInfo) (kinds : Array CongrArgKind) (i : Nat) : Bool := Id.run do
    if info.paramInfo[i].isDecInst then
      for j in info.paramInfo[i].backDeps do
        if kinds[j] matches CongrArgKind.eq then
          return true
    return false

def mkCongrSimp? (f : Expr) : MetaM (Option CongrTheorem) := do
  mkCongrSimpWithArity? f (← getFunInfo f).getArity

end Lean.Meta


import .blackboard .proof_reconstruction .additive .multiplicative data.hash_map .normalizer

open polya tactic

meta structure module_op (α : Type) :=
(a : α)
(op : α → polya_state α)

meta def module_op.update {α} : module_op α → polya_state (module_op α)
| ⟨a, op⟩ := do a' ← op a, return ⟨a', op⟩

meta structure polya_bundle :=
(modules : hash_map ℕ (λ _, sigma module_op))
(num_modules : ℕ)
(bb : blackboard)

namespace polya_bundle

meta def set_changed (b : bool) : polya_bundle → polya_bundle
| ⟨modules, n, bb⟩ := ⟨modules, n, bb.set_changed b⟩

meta def is_changed (pb : polya_bundle) : bool :=
pb.bb.is_changed

meta def contr_found (pb : polya_bundle) : bool :=
pb.bb.contr_found

meta def set_blackboard (pb : polya_bundle) (bb' : blackboard) : polya_bundle :=
{pb with bb := bb'}

meta def update_ith (i : ℕ) : polya_bundle → polya_bundle
| ⟨modules, n, bb⟩ :=
  match modules.find i with
  | some ⟨α, a, op⟩ :=
   let (a', bb') := (op a).run bb,
       modules' := modules.insert i ⟨α, a', op⟩ in
   ⟨modules', n, bb'⟩
  | none := ⟨modules, n, bb⟩
  end

meta def one_cycle (bundle : polya_bundle) : polya_bundle :=
(list.range bundle.num_modules).reverse.foldl (λ pb k, pb.update_ith k) bundle

meta def cycle : ℕ → polya_bundle → (ℕ × polya_bundle) | n pb :=
let pb' := pb.set_changed ff,
    pb' := pb'.one_cycle,
    ch := pb'.is_changed, cont := pb'.contr_found in
if ch && bnot cont then cycle (trace_val (n+1)) pb' else ((n+1), pb')

end polya_bundle

open native

meta def add_module : module_op (rb_set sum_form_comp_data) :=
{ a := mk_rb_set,
  op := @sum_form.add_new_ineqs }

meta def mul_module : module_op (rb_set prod_form_comp_data) :=
{ a := mk_rb_set,
  op := @prod_form.add_new_ineqs }

meta def polya_bundle.default : polya_bundle :=
{ modules := let m' : hash_map ℕ (λ _, sigma module_op) := ((mk_hash_map id).insert 0 ⟨_, add_module⟩) in m'.insert 1 ⟨_, mul_module⟩, -- elab issues
  num_modules := 2,
  bb := blackboard.mk_empty
}

lemma rat_one_gt_zero : (1 : ℚ) > 0 := zero_lt_one

meta def polya_on_hyps (hys : list name) (rct : bool := tt) : tactic unit :=
do exps ← hys.mmap get_local,
   bb ← add_proof_to_blackboard blackboard.mk_empty `(rat_one_gt_zero),
   bb ← add_proofs_to_blackboard bb exps,
   let pb := polya_bundle.default.set_blackboard bb,
   let (n, pb) := pb.cycle 0,
   trace ("number of cycles:", n),
   trace ("contr found", pb.contr_found),
   if bnot pb.contr_found then /-bb.trace >>-/ fail "polya failed, no contradiction found" else
   if rct then pb.bb.contr.reconstruct >>= apply >> skip
   else skip

private meta def try_add_hyp (h : expr) (bb : blackboard) : tactic blackboard :=
add_proof_to_blackboard bb h <|> return bb

private meta def try_add_hyps : list expr → blackboard → tactic blackboard
| [] bb := return bb
| (h::t) bb := do b ← try_add_hyp h bb, try_add_hyps t b

meta def polya_on_all_hyps (rct : bool := tt) : tactic unit :=
do hyps ← local_context,
   bb ← add_proof_to_blackboard blackboard.mk_empty `(rat_one_gt_zero),
   bb ← try_add_hyps hyps bb,
   bb.trace_exprs,
   let pb := polya_bundle.default.set_blackboard bb,
   let (n, pb) := pb.cycle 0,
   trace ("number of cycles:", n),
   trace ("contr found", pb.contr_found),
   if bnot pb.contr_found then /-bb.trace >>-/ fail "polya failed, no contradiction found" else
   if rct then pb.bb.contr.reconstruct >>= apply >> skip
   else skip

/-meta def cycle_ops : ℕ → list (Σ α, module_op α) → polya_state ℕ | n ops :=
do set_changed ff,
   ops' ← ops.mmap (λ m, do m' ← m.2.update, return $ sigma.mk m.1 m'),
   ch ← is_changed, cntr ← contr_found,
   if ch && bnot cntr then cycle_ops (n+1) ops' else return (n+1)

meta def polya_on_hyps (hys : list name) : tactic unit :=
do exps ← hys.mmap get_local,
   bb ← add_proofs_to_blackboard blackboard.mk_empty exps,
   bb.trace_expr_pairs,
   (n, bb) ← return $ cycle_ops 0 [add_new_ineqs, prod_form.add_new_ineqs] bb,
   trace ("number of cycles:", n),
   trace ("contr found", bb.contr_found),
   pf ← bb.contr.reconstruct,
   apply pf-/


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.doc_commands
import Mathlib.PostPort

namespace Mathlib

/-!
# `generalize_proofs`

A simple tactic to find and replace all occurrences of proof terms in the
context and goal with new variables.
-/

namespace tactic

/-- Generalize proofs in the goal, naming them with the provided list. -/
namespace interactive

/-- Generalize proofs in the goal, naming them with the provided list.

For example:
```lean
example : list.nth_le [1, 2] 1 dec_trivial = 2 :=
begin
  -- ⊢ [1, 2].nth_le 1 _ = 2
  generalize_proofs h,
  -- h : 1 < [1, 2].length
  -- ⊢ [1, 2].nth_le 1 h = 2
end
```
-/
end interactive


import Mathlib

def hello := "world"

example {n:Nat}: ∀i, i + (↑n-1-i) = ↑n-1 :=
by
  intro i
  ring