import system.io
-- import .tptp.tptp
import .premise_selection
-- import .tptp.simplification_tptp
-- import .tptp.translation_tptp
import .problem_translation

--#################
--## System test ##
--#################

-- def sum_two (x: ℕ) (y: ℕ) : ℕ := x+y
-- Inductive declaration because the simple version above is not working yet
def sum_two : ℕ → ℕ → ℕ
| x y := x + y

def fib : nat -> nat
| 0 := 1
| 1 := 1
| (nat.succ (nat.succ n)) := fib n + fib (nat.succ n)

def fib2 : nat -> nat
| 0 := 1
| 1 := 1
| (nat.succ (nat.succ n)) := sum_two (fib2 n) (fib2 (nat.succ n))

inductive abc
| a : abc
| b (a : abc) : abc

run_cmd do l ← tactic.get_decl `sum_two, tactic.trace l.value, tactic.trace l.is_definition, l ← tactic.get_eqn_lemmas_for tt `sum_two, d ← tactic.get_decl (list.head l), tactic.trace d.value, (c,_) <- using_hammer $ tactic.infer_type d.value, tactic.trace c
run_cmd do l ← tactic.get_decl `sum_two, tactic.trace l.value, e ← (lambda_expr_to_pi `(sum_two) l.value), tactic.trace e, ⟨f, _⟩ <- using_hammer $ translate_axiom_expression `(sum_two = λ x y:ℕ, x+y), tactic.trace f, tactic.trace `(sum_two=λ x y : ℕ, x+y)
run_cmd do l ← tactic.get_decl `fib, tactic.trace l.value
run_cmd do process_declarations [`sum_two]
-- run_cmd do def_lemmas <- simp_lemmas.mk_default, d ← tactic.get_decl `sum_two, tactic.trace d.value, e <- def_lemmas.dsimplify [`sum_two] d.value, tactic.trace e
-- run_cmd do d <- simp_lemmas.mk_default, l ← tactic.get_decl `sum_two, a <- simp_lemmas.add d l.value, e <- simp_lemmas.rewrite d l.value, tactic.trace e
run_cmd do e <- expr_in_parts `(λ (x:ℕ), x=(λ(y:ℕ),y+x)5), tactic.trace e

run_cmd do l ← tactic.get_decl `abc, tactic.trace l.type, tactic.trace l.is_definition, l ← tactic.get_eqn_lemmas_for ff `abc, tactic.trace l

-- run_cmd do (contents, features, ⟨n, names⟩) ← get_all_decls,
--             tactic.trace $ nearest_k_of_name `sum_two  contents features names 100

-- == SMALL PROBLEM TRANSLATION ==
run_cmd do ⟨f, _⟩ <- using_hammer $ problem_to_tptp_format [] [`(Π(x:ℕ), nat.succ x = x + 1), `(1 : nat), `(1+1 = 2)] `((1+1 = 2)),
           tactic.trace f

-- == EXAMPLE PROBLEM TRANSLATION ==
run_cmd do ⟨f,_⟩ <- using_hammer $ problem_to_tptp_format [`fib2, `sum_two]
                                                     [`(Π(x:ℕ), x + 1 = nat.succ x), `(Π(x y:ℕ),nat.succ x + y = nat.succ (x + y)), `(Π(x y:ℕ),x + y = y + x), `(nat.succ 0 = 1), `(nat.succ 1 = 2), `(nat.succ 2 = 3), `(nat.succ 3 = 4), `(nat.succ 4 = 5), `(nat.succ 5 = 6), `(nat.succ 6 = 7), `(nat.succ 7 = 8), `(0:ℕ), `(1:ℕ), `(2:ℕ), `(3:ℕ), `(4:ℕ), `(5:ℕ), `(6:ℕ), `(7:ℕ), `(8:ℕ)] -- , `(0:ℕ), `(1:ℕ), `(2:ℕ), `(3:ℕ), `(4:ℕ), `(5:ℕ), `(6:ℕ), `(7:ℕ), `(8:ℕ), `(Π x y : ℕ, sum_two x y =x+y)
                                                     `((fib2 5 = 8)),
           tactic.trace f

run_cmd do ⟨f,_⟩ <- using_hammer $ problem_to_tptp_format [`fib]
                        [`(Π(x:ℕ), x + 1 = nat.succ x), `(nat.succ 0 = 1), `(nat.succ 1 = 2), `(0:ℕ), `(1:ℕ)]       -- , `(0:ℕ), `(1:ℕ), `(2:ℕ), `(3:ℕ), `(4:ℕ), `(5:ℕ), `(6:ℕ), `(7:ℕ), `(8:ℕ), `(Π x y : ℕ, sum_two x y =x+y)
                        `((fib 2 = 2)),
           tactic.trace f
--   , `(Π(x y:ℕ),nat.succ x + y = nat.succ (x + y)), `(Π(x y:ℕ),x + y = y + x)

-- =================
-- == OPEN POINTS ==
-- =================
-- 9) Use typed first-order logic (TF0) as encoding instead of plain FOF in TPTP3
-- 1) Lambda expressions to pi notation to translate them similar to the others. Alternative: convert all function declarations into inductive ones.
--    Idea from Rob: look into tactic.dsimplify
-- 4) IO file export
-- 5) How to translate inductive types
-- 7) Proof reconstruction: get a list of assignments for axiom name (as given to SMT solver) and corresponding expression to know which ones were used

-- #################
-- ## IN PROGRESS ##
-- #################
-- 3) Retrieve all definitions of another definition (example 'def sum_twice (x:ℕ) : ℕ := 2 * square(x)' => get definition of square) and add them to axioms
--    => Old code moved to Lean 3.3.0. Relevance filter might be implemented externally in C++ to be faster
-- 8) Simplification of terms => VERY FIRST VERSION replacing constant terms by new constant.
--    Open extensions: -> If a(b, 'nat') and a(b, V1) but 'nat' is the only constant occuring at the second position, we replace this variable by nat
--                     -> Tracable/Understandable constant names for reduced terms (name based on term plus unique prefix)

-- ##########
-- ## DONE ##
-- ##########
-- == DONE == 2) Inductive declarations use different names. E.g. 'fib' is related to as 'fib._main' in the equations
--    Solution: if we find names with "._" suffix, we just cut them off there (hacky, but might work in most cases).
-- == DONE == 6) Inductive: exclude previous cases for each constructor. So if 'def fac (n:ℕ) : ℕ | 0 := 0 | n := n * fac (n-1)' is translated, the second case has 'G(n,Nat) ∧ n != 0 → ...' instead of just checking for nat type as 0 fulfills this as well.
-- == DONE == 10) Split things into multiple files


import Std.Data.Array.Basic
import YatimaStdLib.List

namespace Array

/-- Generates the array of nats from 0,...,n by a given n -/
def iota (n : Nat) : Array Nat :=
  Array.mk (List.range n) |>.push n

def join (l : Array (Array A)) : Array A :=
  Array.foldr (. ++ .) #[] l

instance : Monad Array where
  map := Array.map
  pure x := #[x]
  bind l f := Array.join $ Array.map f l

def shuffle (ar : Array α) (seed : Option Nat := none) [Inhabited α] :
    IO $ Array α := do
  IO.setRandSeed $ seed.getD (← IO.monoMsNow)
  let mut ar := ar
  let size := ar.size
  for i in [0 : size - 2] do
    let j ← IO.rand i.succ (size - 1)
    let tmp := ar[j]!
    ar := ar.set! j ar[i]! |>.set! i tmp
  return ar

/-- Pads the array `ar` with `a` until it has length `n`-/
def pad (ar : Array α) (a : α) (n : Nat) : Array α :=
  let diff := n - ar.size
  ar ++ (.mkArray diff a)

instance [Ord α] : Ord (Array α) where
  compare x y := compare x.data y.data

def last (ar : Array α) : Array α := ar.toSubarray.popFront.toArray

theorem append_size (arr₁ arr₂ : Array α) (h1 : arr₁.size = n) (h2 : arr₂.size = m)
    : (arr₁ ++ arr₂).size = n + m := by
  unfold Array.size at *
  simp [h1, h2]

def stdSizes (maxSize : Nat) := Array.iota maxSize |>.map (2 ^ ·)

def average (arr : Array Nat) : Nat :=
  let sum := arr.foldl (init := 0) fun acc a => acc + a
  sum / arr.size


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, E. W. Ayers
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.over
import Mathlib.category_theory.limits.shapes.finite_limits
import Mathlib.category_theory.yoneda
import Mathlib.order.complete_lattice
import Mathlib.data.set.lattice
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Theory of sieves

- For an object `X` of a category `C`, a `sieve X` is a set of morphisms to `X`
  which is closed under left-composition.
- The complete lattice structure on sieves is given, as well as the Galois insertion
  given by downward-closing.
- A `sieve X` (functorially) induces a presheaf on `C` together with a monomorphism to
  the yoneda embedding of `X`.

## Tags

sieve, pullback
-/

namespace category_theory

/-- A set of arrows all with codomain `X`. -/
def presieve {C : Type u} [category C] (X : C) :=
  {Y : C} → set (Y ⟶ X)

namespace presieve

protected instance inhabited {C : Type u} [category C] {X : C} : Inhabited (presieve X) :=
  { default := ⊤ }

/--
Given a set of arrows `S` all with codomain `X`, and a set of arrows with codomain `Y` for each
`f : Y ⟶ X` in `S`, produce a set of arrows with codomain `X`:
`{ g ≫ f | (f : Y ⟶ X) ∈ S, (g : Z ⟶ Y) ∈ R f }`.
-/
def bind {C : Type u} [category C] {X : C} (S : presieve X) (R : {Y : C} → {f : Y ⟶ X} → S f → presieve Y) : presieve X :=
  fun (Z : C) (h : Z ⟶ X) => ∃ (Y : C), ∃ (g : Z ⟶ Y), ∃ (f : Y ⟶ X), ∃ (H : S f), R H g ∧ g ≫ f = h

@[simp] theorem bind_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} (f : Y ⟶ X) {S : presieve X} {R : {Y : C} → {f : Y ⟶ X} → S f → presieve Y} {g : Z ⟶ Y} (h₁ : S f) (h₂ : R h₁ g) : bind S R (g ≫ f) :=
  Exists.intro Y (Exists.intro g (Exists.intro f (Exists.intro h₁ { left := h₂, right := rfl })))

/-- The singleton presieve.  -/
-- Note we can't make this into `has_singleton` because of the out-param.

structure singleton {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : presieve X
where

@[simp] theorem singleton_eq_iff_domain {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) (g : Y ⟶ X) : singleton f g ↔ f = g := sorry

theorem singleton_self {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : singleton f f :=
  singleton.mk

end presieve

/--
For an object `X` of a category `C`, a `sieve X` is a set of morphisms to `X` which is closed under
left-composition.
-/
structure sieve {C : Type u} [category C] (X : C)
where
  arrows : presieve X
  downward_closed' : ∀ {Y Z : C} {f : Y ⟶ X}, arrows f → ∀ (g : Z ⟶ Y), arrows (g ≫ f)

namespace sieve

protected instance has_coe_to_fun {C : Type u} [category C] {X : C} : has_coe_to_fun (sieve X) :=
  has_coe_to_fun.mk (fun (x : sieve X) => presieve X) arrows

@[simp] theorem downward_closed {C : Type u} [category C] {X : C} {Y : C} {Z : C} (S : sieve X) {f : Y ⟶ X} (hf : coe_fn S Y f) (g : Z ⟶ Y) : coe_fn S Z (g ≫ f) :=
  downward_closed' S hf g

theorem arrows_ext {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} : arrows R = arrows S → R = S := sorry

protected theorem ext {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} (h : ∀ {Y : C} (f : Y ⟶ X), coe_fn R Y f ↔ coe_fn S Y f) : R = S :=
  arrows_ext (funext fun (x : C) => funext fun (f : x ⟶ X) => propext (h f))

protected theorem ext_iff {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} : R = S ↔ ∀ {Y : C} (f : Y ⟶ X), coe_fn R Y f ↔ coe_fn S Y f :=
  { mp := fun (h : R = S) (Y : C) (f : Y ⟶ X) => h ▸ iff.rfl, mpr := sieve.ext }

/-- The supremum of a collection of sieves: the union of them all. -/
protected def Sup {C : Type u} [category C] {X : C} (𝒮 : set (sieve X)) : sieve X :=
  mk (fun (Y : C) => set_of fun (f : Y ⟶ X) => ∃ (S : sieve X), ∃ (H : S ∈ 𝒮), arrows S f) sorry

/-- The infimum of a collection of sieves: the intersection of them all. -/
protected def Inf {C : Type u} [category C] {X : C} (𝒮 : set (sieve X)) : sieve X :=
  mk (fun (Y : C) => set_of fun (f : Y ⟶ X) => ∀ (S : sieve X), S ∈ 𝒮 → arrows S f) sorry

/-- The union of two sieves is a sieve. -/
protected def union {C : Type u} [category C] {X : C} (S : sieve X) (R : sieve X) : sieve X :=
  mk (fun (Y : C) (f : Y ⟶ X) => coe_fn S Y f ∨ coe_fn R Y f) sorry

/-- The intersection of two sieves is a sieve. -/
protected def inter {C : Type u} [category C] {X : C} (S : sieve X) (R : sieve X) : sieve X :=
  mk (fun (Y : C) (f : Y ⟶ X) => coe_fn S Y f ∧ coe_fn R Y f) sorry

/--
Sieves on an object `X` form a complete lattice.
We generate this directly rather than using the galois insertion for nicer definitional properties.
-/
protected instance complete_lattice {C : Type u} [category C] {X : C} : complete_lattice (sieve X) :=
  complete_lattice.mk sieve.union (fun (S R : sieve X) => ∀ {Y : C} (f : Y ⟶ X), coe_fn S Y f → coe_fn R Y f)
    (bounded_lattice.lt._default fun (S R : sieve X) => ∀ {Y : C} (f : Y ⟶ X), coe_fn S Y f → coe_fn R Y f) sorry sorry
    sorry sorry sorry sorry sieve.inter sorry sorry sorry (mk (fun (_x : C) => set.univ) sorry) sorry
    (mk (fun (_x : C) => ∅) sorry) sorry sieve.Sup sieve.Inf sorry sorry sorry sorry

/-- The maximal sieve always exists. -/
protected instance sieve_inhabited {C : Type u} [category C] {X : C} : Inhabited (sieve X) :=
  { default := ⊤ }

@[simp] theorem Inf_apply {C : Type u} [category C] {X : C} {Ss : set (sieve X)} {Y : C} (f : Y ⟶ X) : coe_fn (Inf Ss) Y f ↔ ∀ (S : sieve X), S ∈ Ss → coe_fn S Y f :=
  iff.rfl

@[simp] theorem Sup_apply {C : Type u} [category C] {X : C} {Ss : set (sieve X)} {Y : C} (f : Y ⟶ X) : coe_fn (Sup Ss) Y f ↔ ∃ (S : sieve X), ∃ (H : S ∈ Ss), coe_fn S Y f :=
  iff.rfl

@[simp] theorem inter_apply {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} {Y : C} (f : Y ⟶ X) : coe_fn (R ⊓ S) Y f ↔ coe_fn R Y f ∧ coe_fn S Y f :=
  iff.rfl

@[simp] theorem union_apply {C : Type u} [category C] {X : C} {R : sieve X} {S : sieve X} {Y : C} (f : Y ⟶ X) : coe_fn (R ⊔ S) Y f ↔ coe_fn R Y f ∨ coe_fn S Y f :=
  iff.rfl

@[simp] theorem top_apply {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : coe_fn ⊤ Y f :=
  trivial

/-- Generate the smallest sieve containing the given set of arrows. -/
@[simp] theorem generate_apply {C : Type u} [category C] {X : C} (R : presieve X) (Z : C) (f : Z ⟶ X) : coe_fn (generate R) Z f = ∃ (Y : C), ∃ (h : Z ⟶ Y), ∃ (g : Y ⟶ X), R g ∧ h ≫ g = f :=
  Eq.refl (coe_fn (generate R) Z f)

/--
Given a presieve on `X`, and a sieve on each domain of an arrow in the presieve, we can bind to
produce a sieve on `X`.
-/
@[simp] theorem bind_apply {C : Type u} [category C] {X : C} (S : presieve X) (R : {Y : C} → {f : Y ⟶ X} → S f → sieve Y) : ⇑(bind S R) = presieve.bind S fun (Y : C) (f : Y ⟶ X) (h : S f) => ⇑(R h) :=
  Eq.refl ⇑(bind S R)

theorem sets_iff_generate {C : Type u} [category C] {X : C} (R : presieve X) (S : sieve X) : generate R ≤ S ↔ R ≤ ⇑S := sorry

/-- Show that there is a galois insertion (generate, set_over). -/
def gi_generate {C : Type u} [category C] {X : C} : galois_insertion generate arrows :=
  galois_insertion.mk (fun (𝒢 : presieve X) (_x : arrows (generate 𝒢) ≤ 𝒢) => generate 𝒢) sets_iff_generate sorry sorry

theorem le_generate {C : Type u} [category C] {X : C} (R : presieve X) : R ≤ ⇑(generate R) :=
  galois_connection.le_u_l (galois_insertion.gc gi_generate) R

/-- If the identity arrow is in a sieve, the sieve is maximal. -/
theorem id_mem_iff_eq_top {C : Type u} [category C] {X : C} {S : sieve X} : coe_fn S X 𝟙 ↔ S = ⊤ := sorry

/-- If an arrow set contains a split epi, it generates the maximal sieve. -/
theorem generate_of_contains_split_epi {C : Type u} [category C] {X : C} {Y : C} {R : presieve X} (f : Y ⟶ X) [split_epi f] (hf : R f) : generate R = ⊤ := sorry

@[simp] theorem generate_of_singleton_split_epi {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) [split_epi f] : generate (presieve.singleton f) = ⊤ :=
  generate_of_contains_split_epi f (presieve.singleton_self f)

@[simp] theorem generate_top {C : Type u} [category C] {X : C} : generate ⊤ = ⊤ :=
  generate_of_contains_split_epi 𝟙 True.intro

/-- Given a morphism `h : Y ⟶ X`, send a sieve S on X to a sieve on Y
    as the inverse image of S with `_ ≫ h`.
    That is, `sieve.pullback S h := (≫ h) '⁻¹ S`. -/
def pullback {C : Type u} [category C] {X : C} {Y : C} (h : Y ⟶ X) (S : sieve X) : sieve Y :=
  mk (fun (Y_1 : C) (sl : Y_1 ⟶ Y) => coe_fn S Y_1 (sl ≫ h)) sorry

@[simp] theorem pullback_id {C : Type u} [category C] {X : C} {S : sieve X} : pullback 𝟙 S = S := sorry

@[simp] theorem pullback_top {C : Type u} [category C] {X : C} {Y : C} {f : Y ⟶ X} : pullback f ⊤ = ⊤ :=
  top_unique fun (_x : C) (g : _x ⟶ Y) => id

theorem pullback_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : Y ⟶ X} {g : Z ⟶ Y} (S : sieve X) : pullback (g ≫ f) S = pullback g (pullback f S) := sorry

@[simp] theorem pullback_inter {C : Type u} [category C] {X : C} {Y : C} {f : Y ⟶ X} (S : sieve X) (R : sieve X) : pullback f (S ⊓ R) = pullback f S ⊓ pullback f R := sorry

theorem pullback_eq_top_iff_mem {C : Type u} [category C] {X : C} {Y : C} {S : sieve X} (f : Y ⟶ X) : coe_fn S Y f ↔ pullback f S = ⊤ := sorry

theorem pullback_eq_top_of_mem {C : Type u} [category C] {X : C} {Y : C} (S : sieve X) {f : Y ⟶ X} : coe_fn S Y f → pullback f S = ⊤ :=
  iff.mp (pullback_eq_top_iff_mem f)

/--
Push a sieve `R` on `Y` forward along an arrow `f : Y ⟶ X`: `gf : Z ⟶ X` is in the sieve if `gf`
factors through some `g : Z ⟶ Y` which is in `R`.
-/
@[simp] theorem pushforward_apply {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) (R : sieve Y) (Z : C) (gf : Z ⟶ X) : coe_fn (pushforward f R) Z gf = ∃ (g : Z ⟶ Y), g ≫ f = gf ∧ coe_fn R Z g :=
  Eq.refl (coe_fn (pushforward f R) Z gf)

theorem pushforward_apply_comp {C : Type u} [category C] {X : C} {Y : C} {R : sieve Y} {Z : C} {g : Z ⟶ Y} (hg : coe_fn R Z g) (f : Y ⟶ X) : coe_fn (pushforward f R) Z (g ≫ f) :=
  Exists.intro g { left := rfl, right := hg }

theorem pushforward_comp {C : Type u} [category C] {X : C} {Y : C} {Z : C} {f : Y ⟶ X} {g : Z ⟶ Y} (R : sieve Z) : pushforward (g ≫ f) R = pushforward f (pushforward g R) := sorry

theorem galois_connection {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : galois_connection (pushforward f) (pullback f) := sorry

theorem pullback_monotone {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : monotone (pullback f) :=
  galois_connection.monotone_u (galois_connection f)

theorem pushforward_monotone {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) : monotone (pushforward f) :=
  galois_connection.monotone_l (galois_connection f)

theorem le_pushforward_pullback {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) (R : sieve Y) : R ≤ pullback f (pushforward f R) :=
  galois_connection.le_u_l (galois_connection f) R

theorem pullback_pushforward_le {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) (R : sieve X) : pushforward f (pullback f R) ≤ R :=
  galois_connection.l_u_le (galois_connection f) R

theorem pushforward_union {C : Type u} [category C] {X : C} {Y : C} {f : Y ⟶ X} (S : sieve Y) (R : sieve Y) : pushforward f (S ⊔ R) = pushforward f S ⊔ pushforward f R :=
  galois_connection.l_sup (galois_connection f)

theorem pushforward_le_bind_of_mem {C : Type u} [category C] {X : C} {Y : C} (S : presieve X) (R : {Y : C} → {f : Y ⟶ X} → S f → sieve Y) (f : Y ⟶ X) (h : S f) : pushforward f (R h) ≤ bind S R := sorry

theorem le_pullback_bind {C : Type u} [category C] {X : C} {Y : C} (S : presieve X) (R : {Y : C} → {f : Y ⟶ X} → S f → sieve Y) (f : Y ⟶ X) (h : S f) : R h ≤ pullback f (bind S R) :=
  eq.mpr
    (id (Eq._oldrec (Eq.refl (R h ≤ pullback f (bind S R))) (Eq.symm (propext (galois_connection f (R h) (bind S R))))))
    (pushforward_le_bind_of_mem (fun {Y : C} (f : Y ⟶ X) => S f) R f h)

/-- If `f` is a monomorphism, the pushforward-pullback adjunction on sieves is coreflective. -/
def galois_coinsertion_of_mono {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) [mono f] : galois_coinsertion (pushforward f) (pullback f) :=
  galois_connection.to_galois_coinsertion (galois_connection f) sorry

/-- If `f` is a split epi, the pushforward-pullback adjunction on sieves is reflective. -/
def galois_insertion_of_split_epi {C : Type u} [category C] {X : C} {Y : C} (f : Y ⟶ X) [split_epi f] : galois_insertion (pushforward f) (pullback f) :=
  galois_connection.to_galois_insertion (galois_connection f) sorry

/-- A sieve induces a presheaf. -/
@[simp] theorem functor_obj {C : Type u} [category C] {X : C} (S : sieve X) (Y : Cᵒᵖ) : functor.obj (functor S) Y = Subtype fun (g : opposite.unop Y ⟶ X) => coe_fn S (opposite.unop Y) g :=
  Eq.refl (functor.obj (functor S) Y)

/--
If a sieve S is contained in a sieve T, then we have a morphism of presheaves on their induced
presheaves.
-/
def nat_trans_of_le {C : Type u} [category C] {X : C} {S : sieve X} {T : sieve X} (h : S ≤ T) : functor S ⟶ functor T :=
  nat_trans.mk fun (Y : Cᵒᵖ) (f : functor.obj (functor S) Y) => { val := subtype.val f, property := sorry }

/-- The natural inclusion from the functor induced by a sieve to the yoneda embedding. -/
@[simp] theorem functor_inclusion_app {C : Type u} [category C] {X : C} (S : sieve X) (Y : Cᵒᵖ) (f : functor.obj (functor S) Y) : nat_trans.app (functor_inclusion S) Y f = subtype.val f :=
  Eq.refl (nat_trans.app (functor_inclusion S) Y f)

theorem nat_trans_of_le_comm {C : Type u} [category C] {X : C} {S : sieve X} {T : sieve X} (h : S ≤ T) : nat_trans_of_le h ≫ functor_inclusion T = functor_inclusion S :=
  rfl

/-- The presheaf induced by a sieve is a subobject of the yoneda embedding. -/
protected instance functor_inclusion_is_mono {C : Type u} [category C] {X : C} {S : sieve X} : mono (functor_inclusion S) :=
  mono.mk
    fun (Z : Cᵒᵖ ⥤ Type v) (f g : Z ⟶ functor S) (h : f ≫ functor_inclusion S = g ≫ functor_inclusion S) =>
      nat_trans.ext f g
        (funext fun (Y : Cᵒᵖ) => funext fun (y : functor.obj Z Y) => subtype.ext (congr_fun (nat_trans.congr_app h Y) y))

/--
A natural transformation to a representable functor induces a sieve. This is the left inverse of
`functor_inclusion`, shown in `sieve_of_functor_inclusion`.
-/
-- TODO: Show that when `f` is mono, this is right inverse to `functor_inclusion` up to isomorphism.

@[simp] theorem sieve_of_subfunctor_apply {C : Type u} [category C] {X : C} {R : Cᵒᵖ ⥤ Type v} (f : R ⟶ functor.obj yoneda X) (Y : C) (g : Y ⟶ X) : coe_fn (sieve_of_subfunctor f) Y g = ∃ (t : functor.obj R (opposite.op Y)), nat_trans.app f (opposite.op Y) t = g :=
  Eq.refl (coe_fn (sieve_of_subfunctor f) Y g)

theorem sieve_of_subfunctor_functor_inclusion {C : Type u} [category C] {X : C} {S : sieve X} : sieve_of_subfunctor (functor_inclusion S) = S := sorry

protected instance functor_inclusion_top_is_iso {C : Type u} [category C] {X : C} : is_iso (functor_inclusion ⊤) :=
  is_iso.mk
    (nat_trans.mk fun (Y : Cᵒᵖ) (a : functor.obj (functor.obj yoneda X) Y) => { val := a, property := True.intro })


import QL.FOL.deduction

universes u v

namespace fol
open_locale logic_symbol aclogic
open subterm subformula logic logic.Theory
variables {L R : language.{u}} {L₁ L₂ L₃ : language} {μ : Type v} {m n : ℕ}

namespace language

structure translation (L₁ : language) (L₂ : language) :=
(fn : Π n, L₁.fn n → L₂.fn n)
(pr : Π n, L₁.pr n → L₂.pr n)
(fn_inj : ∀ n, function.injective (fn n))
(pr_inj : ∀ n, function.injective (pr n))

infix ` ⤳ᴸ `:25 := translation

protected def translation.refl : L ⤳ᴸ L :=
{ fn := λ _, id,
  pr := λ _, id,
  fn_inj := λ _, function.injective_id,
  pr_inj := λ _, function.injective_id }

protected def translation.comp (τ₁ : L₁ ⤳ᴸ L₂) (τ₂ : L₂ ⤳ᴸ L₃) : L₁ ⤳ᴸ L₃ :=
{ fn := λ n, τ₂.fn n ∘ τ₁.fn n,
  pr := λ n, τ₂.pr n ∘ τ₁.pr n,
  fn_inj := λ n, function.injective.comp (τ₂.fn_inj n) (τ₁.fn_inj n),
  pr_inj := λ n, function.injective.comp (τ₂.pr_inj n) (τ₁.pr_inj n) }

instance : has_add language := ⟨λ L₁ L₂ : language.{u}, ⟨λ n, L₁.fn n ⊕ L₂.fn n, λ n, L₁.pr n ⊕ L₂.pr n⟩⟩

def padd (L₁ : language.{u}) (L₂ : language.{v}) : language.{max u v} := ⟨λ n, L₁.fn n ⊕ L₂.fn n, λ n, L₁.pr n ⊕ L₂.pr n⟩

section add
variables {L R}

instance add_to_string_fn [∀ n, has_to_string (L.fn n)] [∀ n, has_to_string (R.fn n)] (n) : has_to_string ((L + R).fn n) :=
⟨by { rintros (x | x), { exact to_string x }, { exact to_string x } }⟩

instance add_to_string_pr [∀ n, has_to_string (L.pr n)] [∀ n, has_to_string (R.pr n)] (n) : has_to_string ((L + R).pr n) :=
⟨by { rintros (x | x), { exact to_string x }, { exact to_string x } }⟩

def add_left : L ⤳ᴸ L + R :=
{ fn := λ n f, sum.inl f, pr := λ n r, sum.inl r,
  fn_inj := λ n, sum.inl_injective,
  pr_inj := λ n, sum.inl_injective }

def add_right : R ⤳ᴸ L + R :=
{ fn := λ n f, sum.inr f, pr := λ n r, sum.inr r,
  fn_inj := λ n, sum.inr_injective,
  pr_inj := λ n, sum.inr_injective }

end add

section padd
variables {L' : language.{u}} {R' : language.{v}}

def padd_left : L' ⤳ᴸ L'.padd R' :=
{ fn := λ n f, sum.inl f, pr := λ n r, sum.inl r,
  fn_inj := λ n, sum.inl_injective,
  pr_inj := λ n, sum.inl_injective }

def padd_right : R' ⤳ᴸ L'.padd R' :=
{ fn := λ n f, sum.inr f, pr := λ n r, sum.inr r,
  fn_inj := λ n, sum.inr_injective,
  pr_inj := λ n, sum.inr_injective }

end padd

@[reducible] def Constants (α : Type*) : language := { fn := nat.cases α (λ _, pempty), pr := λ _, pempty }

section Constants
variables {α : Type*}

instance : has_coe α (subterm (Constants α) μ n) := ⟨@subterm.const (Constants α) μ n⟩

end Constants

end language

namespace subterm
open language
variables (μ n)

structure hom (L₁ : language) (L₂ : language) :=
(func {} : Π {n k}, L₁.fn k → (fin k → subterm L₂ μ n) → subterm L₂ μ n)
(to_fun : Π {n}, subterm L₁ μ n → subterm L₂ μ n)
(map_var' : ∀ {n x}, to_fun (#x : subterm L₁ μ n) = #x)
(map_metavar' : ∀ {n x}, to_fun (&x : subterm L₁ μ n) = &x)
(map_function' : ∀ {n k} (f : L₁.fn k) (v : fin k → subterm L₁ μ n),
  to_fun (function f v) = func f (λ i, to_fun (v i)))

instance {L₁ L₂ : language} :
  has_coe_to_fun (hom μ L₁ L₂) (λ _, Π {n}, subterm L₁ μ n → subterm L₂ μ n) :=
⟨hom.to_fun⟩

namespace hom
variables {L₁ L₂ μ m n} (τ : hom μ L₁ L₂)
/--/
@[simp] lemma map_var {n x} : τ (#x : subterm L₁ μ n) = #x := τ.map_var'

@[simp] lemma map_metavar {n x} : τ (&x : subterm L₁ μ n) = &x := τ.map_metavar'

lemma map_function {k n} (f : L₁.fn k) (v : fin k → subterm L₁ μ n) :
  τ (function f v) = func τ f (λ i, τ (v i)) := τ.map_function' f v

@[simp] lemma map_mlift {n} (t : subterm L₁ μ n) : τ t.mlift = (τ t).mlift := τ.map_mlift' t

@[simp] lemma map_push {m n} (t : subterm L₁ m (n + 1)) : τ t.push = (τ t).push := τ.map_push' t

@[simp] lemma map_pull {m n} (t : subterm L₁ (m + 1) n) : τ t.pull = (τ t).pull := τ.map_pull' t

end hom

@[simp] def of_fn_hom (fn : Π n, L₁.fn n → L₂.fn n) : subterm L₁ m n → subterm L₂ m n
| &x             := &x
| #x             := #x
| (function f v) := function (fn _ f) (λ i, of_fn_hom (v i))

def of_fn (fn : Π n, L₁.fn n → L₂.fn n) : hom L₁ L₂ :=
{ func := λ k m n f, function (fn _ f),
  to_fun := λ m n, @of_fn_hom _ _ m n fn,
  map_var' := by intros; refl,
  map_metavar' := by intros; refl,
  map_function' := by intros; simp,
  map_mlift' := by intros m n t; induction t; simp*,
  map_push' := by {intros m n t; induction t; simp*, case var : x { refine fin.last_cases _ _ x; simp } },
  map_pull' := by {intros m n t; induction t; simp*, case metavar : x { refine fin.last_cases _ _ x; simp } } }

def of_lhom (l : L₁ ⤳ᴸ L₂) : hom L₁ L₂ := of_fn l.fn

variables (l : L₁ ⤳ᴸ L₂)

@[simp] lemma of_lhom_map_function {k m n} (f : L₁.fn k) (v : fin k → subterm L₁ m n) :
  (of_lhom l) (function f v) = function (l.fn _ f) (λ i, of_lhom l (v i)) :=
by simp[of_lhom]; refl

variables {L R}

def left : subterm.hom L (L + R) := subterm.of_lhom add_left

def right : subterm.hom R (L + R) := subterm.of_lhom add_right

end subterm

namespace subformula
open language

structure hom (L₁ : language) (L₂ : language) :=
(hom : Π {m n}, subformula L₁ m n →ₗ subformula L₂ m n)
(map_univ' : ∀ {m n} (p : subformula L₁ m (n + 1)), hom (∀'p) = ∀' hom p)
(map_mlift' : ∀ {m n} (p : subformula L₁ m n), hom p.mlift = (hom p).mlift)
(map_push' : ∀ {m n} (p : subformula L₁ m (n + 1)), hom p.push = (hom p).push)
(map_pull' : ∀ {m n} (p : subformula L₁ (m + 1) n), hom p.pull = (hom p).pull)

instance {L₁ L₂ : language} :
  has_coe_to_fun (hom L₁ L₂) (λ _, Π {m n}, subformula L₁ m n →ₗ subformula L₂ m n) :=
⟨hom.hom⟩

namespace hom
variables (τ : subformula.hom L₁ L₂) {m}

@[simp] lemma map_univ {m n} (p : subformula L₁ m (n + 1)) : τ (∀'p) = ∀'τ p := τ.map_univ' p

@[simp] lemma map_ex {m n} (p : subformula L₁ m (n + 1)) : τ (∃'p) = ∃'τ p := by simp[ex_def]

@[simp] lemma map_mlift {m n} (p : subformula L₁ m n) : τ p.mlift = (τ p).mlift := τ.map_mlift' p

@[simp] lemma map_push {m n} (p : subformula L₁ m (n + 1)) : τ p.push = (τ p).push := τ.map_push' p

@[simp] lemma map_pull {m n} (p : subformula L₁ (m + 1) n) : τ p.pull = (τ p).pull := τ.map_pull' p

@[simp] lemma map_dummy {m n} (p : subformula L₁ m n) : τ p.dummy = (τ p).dummy :=
by simp[dummy]

@[simp] lemma map_univ_closure {m n} (p : subformula L₁ m n) : τ (∀'*p) = ∀'*(τ p) :=
by induction n; simp*

@[simp] lemma map_exists_closure {m n} (p : subformula L₁ m n) : τ (∃'*p) = ∃'*(τ p) :=
by induction n; simp*

@[reducible] def on_Theory (T : preTheory L₁ m) : preTheory L₂ m := (λ p, τ p) '' T

@[simp] lemma on_Theory_map_mlift {m} (T : preTheory L₁ m) : τ.on_Theory T.mlift = (τ.on_Theory T).mlift :=
by ext p; simp[on_Theory, preTheory.mlift]

class provable :=
(subst : ∀ {m} (T : preTheory L₁ m) (p t), τ.on_Theory T ⊢ ∀'τ p ⟶ τ (subst t p))

end hom

variables (l : L₁ ⤳ᴸ L₂) {m}

@[simp] def of_lhom_hom : Π {n}, subformula L₁ m n → subformula L₂ m n
| n verum          := ⊤
| n (relation r v) := relation (l.pr _ r) (λ i, subterm.of_lhom l (v i))
| n (imply p q)    := of_lhom_hom p ⟶ of_lhom_hom q
| n (neg p)        := ∼of_lhom_hom p
| n (fal p)        := ∀' of_lhom_hom p

@[simp] def of_lhom_hom_verum : of_lhom_hom l (⊤ : subformula L₁ m n) = ⊤ := by refl

@[simp] def of_lhom_hom_relation {k} (r : L₁.pr k) (v : fin k → subterm L₁ m n) :
  of_lhom_hom l (relation r v : subformula L₁ m n) = relation (l.pr _ r) (λ i, subterm.of_lhom l (v i)) := by refl

@[simp] def of_lhom_hom_imply (p q : subformula L₁ m n) :
  of_lhom_hom l (p ⟶ q) = (of_lhom_hom l p ⟶ of_lhom_hom l q) := by refl

@[simp] def of_lhom_hom_neg (p : subformula L₁ m n) :
  of_lhom_hom l (∼p) = ∼of_lhom_hom l p := by refl

@[simp] def of_lhom_hom_fal (p : subformula L₁ m (n + 1)) :
  of_lhom_hom l (∀'p) = ∀'of_lhom_hom l p := by refl

@[simp] def mlift_of_lhom_hom : Π {n} (p : subformula L₁ m n), mlift (of_lhom_hom l p) = of_lhom_hom l (mlift p)
| n verum          := by simp[top_eq]; refl
| n (relation r v) := by simp
| n (imply p q)    := by simp[imply_eq, mlift_of_lhom_hom p, mlift_of_lhom_hom q]
| n (neg p)        := by simp[neg_eq, mlift_of_lhom_hom p]
| n (fal p)        := by simp[fal_eq, mlift_of_lhom_hom p]

@[simp] def push_of_lhom_hom : Π {n} (p : subformula L₁ m (n + 1)), push (of_lhom_hom l p) = of_lhom_hom l (push p)
| n verum          := by simp[top_eq]; refl
| n (relation r v) := by simp
| n (imply p q)    := by simp[imply_eq, push_of_lhom_hom p, push_of_lhom_hom q]
| n (neg p)        := by simp[neg_eq, push_of_lhom_hom p]
| n (fal p)        := by simp[fal_eq, push_of_lhom_hom p]
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ x, x.2.complexity)⟩]}

@[simp] def pull_of_lhom_hom : Π {n} (p : subformula L₁ (m + 1) n), pull (of_lhom_hom l p) = of_lhom_hom l (pull p)
| n verum          := by simp[top_eq]; refl
| n (relation r v) := by simp
| n (imply p q)    := by simp[imply_eq, pull_of_lhom_hom p, pull_of_lhom_hom q]
| n (neg p)        := by simp[neg_eq, pull_of_lhom_hom p]
| n (fal p)        := by simp[fal_eq, pull_of_lhom_hom p]

def of_lhom : subformula.hom L₁ L₂ :=
{ hom := λ m n,
  { to_fun := of_lhom_hom l,
    map_neg' := λ p, by refl,
    map_imply' := λ p q, by refl,
    map_and' := λ p q, by refl,
    map_or' := λ p q, by refl,
    map_top' := by refl,
    map_bot' := by refl },
  map_univ' := λ m n p, by refl,
  map_mlift' := by simp,
  map_push' := by simp,
  map_pull' := by simp }

@[simp] lemma of_lhom_relation {k} (r : L₁.pr k) (v : fin k → subterm L₁ m n) :
  of_lhom l (relation r v) = relation (l.pr _ r) (λ i, (subterm.of_lhom l) (v i)) :=
by refl

@[simp] lemma rank_of_lhom : ∀ {n} (p : subformula L₁ m n), (of_lhom l p).qr = p.qr
| n verum          := by simp[top_eq]
| n (relation r v) := by simp
| n (imply p q)    := by simp[imply_eq, rank_of_lhom p, rank_of_lhom q]
| n (neg p)        := by simp[neg_eq, rank_of_lhom p]
| n (fal p)        := by simp[fal_eq, rank_of_lhom p]

@[simp] lemma of_lhom_is_open (p : subformula L₁ m n) : (of_lhom l p).is_open ↔ p.is_open :=
by simp[is_open]

@[simp] lemma complexity_of_lhom : ∀ {n} (p : subformula L₁ m n), (of_lhom l p).complexity = p.complexity
| n verum          := by simp[top_eq]
| n (relation r v) := by simp
| n (imply p q)    := by simp[imply_eq, complexity_of_lhom p, complexity_of_lhom q]
| n (neg p)        := by simp[neg_eq, complexity_of_lhom p]
| n (fal p)        := by simp[fal_eq, complexity_of_lhom p]

variables {L R}

def left : subformula.hom L (L + R) := subformula.of_lhom add_left

def right : subformula.hom R (L + R) := subformula.of_lhom add_right

end subformula

end fol


syntax "foo! " term:max : term
macro_rules
  | `(foo! $x) => `($x + 1)

#eval foo! 2

theorem ex1 : foo! 2 = 3 :=
  rfl

syntax (priority := high) "foo!" term:max : term

macro_rules
  | `(foo! $x) => `($x * 2)

theorem ex2 : foo! 2 = 4 :=
  rfl


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.functor.const
import category_theory.discrete_category

/-!
# The category `discrete punit`

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

We define `star : C ⥤ discrete punit` sending everything to `punit.star`,
show that any two functors to `discrete punit` are naturally isomorphic,
and construct the equivalence `(discrete punit ⥤ C) ≌ C`.
-/

universes v u -- morphism levels before object levels. See note [category_theory universes].

namespace category_theory
variables (C : Type u) [category.{v} C]

namespace functor

/-- The constant functor sending everything to `punit.star`. -/
@[simps]
def star : C ⥤ discrete punit :=
(functor.const _).obj ⟨⟨⟩⟩

variable {C}
/-- Any two functors to `discrete punit` are isomorphic. -/
@[simps]
def punit_ext (F G : C ⥤ discrete punit) : F ≅ G :=
nat_iso.of_components (λ _, eq_to_iso dec_trivial) (λ _ _ _, dec_trivial)

/--
Any two functors to `discrete punit` are *equal*.
You probably want to use `punit_ext` instead of this.
-/
lemma punit_ext' (F G : C ⥤ discrete punit) : F = G :=
functor.ext (λ _, dec_trivial) (λ _ _ _, dec_trivial)

/-- The functor from `discrete punit` sending everything to the given object. -/
abbreviation from_punit (X : C) : discrete punit.{v+1} ⥤ C :=
(functor.const _).obj X

/-- Functors from `discrete punit` are equivalent to the category itself. -/
@[simps]
def equiv : (discrete punit ⥤ C) ≌ C :=
{ functor :=
  { obj := λ F, F.obj ⟨⟨⟩⟩,
    map := λ F G θ, θ.app ⟨⟨⟩⟩ },
  inverse := functor.const _,
  unit_iso :=
  begin
    apply nat_iso.of_components _ _,
    intro X,
    apply discrete.nat_iso,
    rintro ⟨⟨⟩⟩,
    apply iso.refl _,
    intros,
    ext ⟨⟨⟩⟩,
    simp,
  end,
  counit_iso :=
  begin
    refine nat_iso.of_components iso.refl _,
    intros X Y f,
    dsimp, simp,  -- See note [dsimp, simp].
  end }

end functor

/-- A category being equivalent to `punit` is equivalent to it having a unique morphism between
  any two objects. (In fact, such a category is also a groupoid; see `groupoid.of_hom_unique`) -/
theorem equiv_punit_iff_unique :
  nonempty (C ≌ discrete punit) ↔ (nonempty C) ∧ (∀ x y : C, nonempty $ unique (x ⟶ y)) :=
begin
  split,
  { rintro ⟨h⟩,
    refine ⟨⟨h.inverse.obj ⟨⟨⟩⟩⟩, λ x y, nonempty.intro _⟩,
    apply (unique_of_subsingleton _), swap,
    { have hx : x ⟶ h.inverse.obj ⟨⟨⟩⟩ := by convert h.unit.app x,
      have hy : h.inverse.obj ⟨⟨⟩⟩ ⟶ y := by convert h.unit_inv.app y,
      exact hx ≫ hy, },
    have : ∀ z, z = h.unit.app x ≫ (h.functor ⋙ h.inverse).map z ≫ h.unit_inv.app y,
    { intro z, simpa using congr_arg (≫ (h.unit_inv.app y)) (h.unit.naturality z), },
    apply subsingleton.intro,
    intros a b,
    rw [this a, this b],
    simp only [functor.comp_map], congr, },
  { rintro ⟨⟨p⟩, h⟩,
    haveI := λ x y, (h x y).some,
    refine nonempty.intro (category_theory.equivalence.mk
      ((functor.const _).obj ⟨⟨⟩⟩) ((functor.const _).obj p) _ (by apply functor.punit_ext)),
    exact nat_iso.of_components (λ _, { hom := default, inv := default }) (λ _ _ _, by tidy), },
end

end category_theory


import init.data.option.basic

open tactic
open monad
open expr
open smt_tactic

theorem nonethm {t} : (none <|> none)=@none t:= rfl.

theorem nonethm2 {t} {x:option t} : (x <|> none)=x:= begin
    cases x;refl
end

theorem th : ∀ (a:ℕ) (b:ℕ), a ≠ b → (if a=b then 5 else 3)=3 :=
begin
    intros, simp *
end

def f (x : ℕ) := x+1

theorem fsimp : f 0 = 1 :=
begin
    unfold f
end

theorem fsimp2 {e : ℕ } : (λ x : ℕ, x+(f 0)=1+x)=(λ x : ℕ, 1=1) :=
begin
    rewrite fsimp, simp
end

theorem fsimp3 { x : ℕ } : x=0 → f x = 1 :=
begin
    intro, unfold f, rw a
end

theorem fsimp4 {e : ℕ } : e=0 → (λ x : ℕ, x+(f x)=1+x) e=(λ x : ℕ, 1=1) e :=
begin
    intro, conv
    begin
        to_lhs,
        simp, rw a,
        funext,
        rw fsimp3, skip, reflexivity
    end
end

meta def simplifyProd : expr → expr
| (expr.app
    (expr.app
      (expr.app `(@prod.fst) tt1a)
      tt1b)
     (expr.app
        (expr.app
          (expr.app
            (expr.app `(@prod.mk) tt1) tt2) a) b)) := a
--| `((λ x, (%%f) x) (%%z)) := `(%%f (%%z+1))
| (expr.app a b) := expr.app (simplifyProd a) (simplifyProd b)
| (expr.lam v b t e) := expr.lam v b (simplifyProd t) (simplifyProd e)
| (expr.pi v b t e) := expr.pi v b (simplifyProd t) (simplifyProd e)
| x := x

meta def simplifyProd2 : expr → expr
| (expr.app
    (expr.app
      (expr.app pf tt1a)
      tt1b)
     (expr.app
        (expr.app
          (expr.app
            (expr.app pm tt1) tt2) a) b)) := a
--| `((λ x, (%%f) x) (%%z)) := `(%%f (%%z+1))
| (expr.app a b) := expr.app (simplifyProd2 a) (simplifyProd2 b)
| (expr.lam v b t e) := expr.lam v b (simplifyProd2 t) (simplifyProd2 e)
| (expr.pi v b t e) := expr.pi v b (simplifyProd2 t) (simplifyProd2 e)
| x := x

theorem testit (f:ℕ) (s:ℕ) :
    (f,s).fst=f :=
begin
   do {
       t ← target,
       trace "Start2",
       trace t.to_raw_fmt,
       tq ← some (simplifyProd t),
       trace "Finish2",
       trace tq.to_raw_fmt,
       assert `hhhq tq,tactic.swap,admit
   },
   refl
end

theorem test : 1=2 :=
begin
    suffices hh:(3=4), admit,
end

meta def test : expr → expr
| (expr.lam vn b ttt (expr.app f s)) :=
      (expr.lam vn b ttt
          (expr.app f (expr.app (expr.app `(nat.add) s) `(1))))
| x := x.

theorem junk { p : Prop } { q : Prop } : (p ∨ false ∨ (q ∧ false))=p :=
begin
    sorry
end

theorem test_split { P : ℕ → Prop } { Q : ℕ → Prop } { R : ℕ → Prop } { S : ℕ → Prop } :
    (∀ x, P x ∧ (Q x ∨ R x)) → (∀ x, Q x → S x) → (∀ x, R x → S x) → (∀ x, P x ∧ S x) :=
begin
    intros h h' h'' x,
    specialize h x,
    specialize h' x,
    specialize h'' x, split, cases h, apply h_left,
    cases h, cases h_right, apply h', apply h_right,
    apply h'', apply h_right
end

inductive Value : Type
| NatValue : ℕ -> Value
| ListValue : list Value -> Value
| NoValue : Value

mutual def rangeSet, rangeSetList
with rangeSet : Value -> option (list nat)
| (Value.ListValue ((Value.NatValue loc)::r)) :=
   match rangeSetList r with
   | option.some ll := option.some (loc::ll)
   | _              := option.none
   end
| (Value.NatValue _) := option.some list.nil
| _                  := option.none
with rangeSetList : list Value → option (list nat)
| (f::r) := match rangeSet f
                     with
                     | some l :=
                         match rangeSetList r with
                         | option.some ll := (some (append l ll))
                         | _ := option.none
                         end
                     | _     := option.none
                     end
| _ := @list.nil ℕ.

def beq_nat : ℕ → ℕ → bool
| 0 0 := tt
| (x+1) (y+1) := (beq_nat x y)
| (x+1) 0 := ff
| 0 (x+1) := ff

def listmem : ℕ → list ℕ → bool
| _ list.nil := ff
| e (list.cons a b) := if beq_nat e a then tt else listmem e b

def Rmember : ℕ → Value → bool
| a v := match (rangeSet v) with
         | option.some l := listmem a l
         | option.none := ff
         end

theorem Rmember1 { a:ℕ } { v:Value } { l:list ℕ } :
        some l = rangeSet v → listmem a l=Rmember a v:= begin
        intros, unfold Rmember, rewrite ← a_1,
        simp only [Rmember._match_1]
end

theorem rootIsMemberAux (root:ℕ) (r:list Value) :
        Rmember root (Value.ListValue (Value.NatValue root :: r)) = to_bool true :=
begin
    rewrite ← Rmember1, swap,
end

theorem x: ∃ x, x=5 :=
begin existsi _, ..
end

def qq (x : ℕ) := x.

inductive ev : ℕ → Prop
| Base : ev 0
| Inductive : forall x, ev x → ev (x+2).

def evv (x :ℕ → ℕ) (y: ℕ):=
    match x y with
    | 0 := tt
    | 1 := ff
    | _ := tt
    end

theorem test: ∀ x (f: ℕ → ℕ), f x=0 → evv f x :=
begin
    intros, unfold evv, rw a, simp only [evv._match_1], rw a, exact rfl,
end

inductive od : ℕ → Prop
| Base : od 1
| Inductive : forall x, od x → od x.

inductive ev2 : ℕ → ℕ → ℕ → Prop
| Base : ∀ (a:ℕ) (b:ℕ) (c:ℕ), ev a → b=qq c → ev2 a (b*2) c.

theorem dd : (λ (x:ℕ), x*2)=(λ (x:ℕ), x+x) := begin
    have h:∀ x, x*2=x+x, intro, admit,
    rw h
end

theorem evod (x:ℕ) (y:ℕ) (z:ℕ): ev2 x y z → od (x+1) :=
begin
    intro, cases a, simp, apply od.Base,

    simp, simp at a,
end

def xeval (a : ℕ) (b : ℕ) := if a=0 then 0 else b.

def beq_nat : ℕ → ℕ → bool
| 0 0 := tt
| (x+1) (y+1) := (beq_nat x y)
| (x+1) 0 := ff
| 0 (x+1) := ff

theorem testdummy : (λ (l : ident), ite ↥(beq_nat v l) v2 (ite ↥(beq_nat v l) v1 (env l))) =
    λ (l : ident), ite ↥(beq_nat v l) v2 (env l)
begin
end

meta def evaluate_xeval_helper : expr → expr
| `(xeval %%x %%y) :=
      (app (app (app `(ite)
                     (app (app `(beq_nat))) x `(0))
                     `(0))
                     y)
| x := x

def andFuns (a : ℕ → Prop) (b : ℕ → Prop) : ℕ → Prop :=
    (λ q, (a q) ∧ (b q)).

def existsFuns (a : ℕ → ℕ → Prop) : ℕ → Prop :=
    (λ n, (∃ (e:ℕ), a e n)).

def test := (λ x, x > 3)
def test2 := (λ x, x < 8)
def test3 := (λ (x y:ℕ), x=y)

#check existsFuns.

--meta def divide_lambda1 : name → binder_info → expr → expr → expr → expr → expr
--| n b e1 `(andFuns %%l %%r) v y :=
--      (app (app `(andFuns) (divide_lambda1 n b e1 l v y))
--                           (divide_lambda1 n b e1 r v y))
--| n b e1 x y v := (app (lam n b e1 (app x y)) v).

--meta def transform_lambda_app1 : expr → option expr
--| (app (lam n b e1 (app x y)) val) := some (divide_lambda1 n b e1 x y val)
--| _ := none.

--meta def split_lambda1 : tactic unit :=
--do { t ← target,
--     nt ← transform_lambda_app1 t,
--     (change nt) }.

meta def divide_lambda : name → binder_info → expr → expr → expr → expr
| n b e1 `(andFuns %%l %%r) y :=
      (app (app `(andFuns) (divide_lambda n b e1 l y))
                           (divide_lambda n b e1 r y))
| n b e1 `(existsFuns (λ (qqq:ℕ), %%ll)) y :=
      (app (const "existsFuns" [])
                 (lam "qqq" binder_info.default e1 (divide_lambda n b e1 (ll.lift_vars 0 1) y)))
--      (existsFuns (λ (qqq:ℕ), %%(divide_lambda n b e1 (ll.lift_vars 0 1) y)))
--| n b e1 (app (app `(existsFuns) (lam qqq bi nt ll))) yy :=
--      (app (const "existsFuns" [])
--                 (lam qqq bi nt (divide_lambda n b e1 (ll.lift_vars 0 1) yy)))
| n b e1 x y := (lam n b e1 (app x y)).

meta def transform_lambda_app : expr → option expr
| (app (lam n b e1 (app x y)) val) := some (app (divide_lambda n b e1 x y) val)
| (app `(id %%(lam n b e1 (app x y))) val) := some (app (divide_lambda n b e1 x y) val)
| _ := none

meta def split_lambda : tactic unit :=
do { t ← target,
     --trace t.to_raw_fmt,
     nt ← transform_lambda_app t,
     --trace nt.to_raw_fmt,
     change nt }

meta def test_dummy : tactic unit :=
do {
     test ← some ``((λ (v:ℕ),v=%%(@var tt 1)) 3),
     trace test.to_raw_fmt,
     admit
   }

theorem dummy : 3=4 :=
begin
    test_dummy
end

theorem test1 (v: ℕ) : id (λ (e:ℕ), (andFuns test test2) (e+1)) v :=
begin
  unfold test, unfold test2,
  split_lambda,
end

theorem test1 (v: ℕ) : (λ (e:ℕ), (andFuns test test2) (e+1)) v :=
begin
    unfold test, unfold test2,
    change (andFuns (λ (e:ℕ), test (e+1)) (λ (e:ℕ), test2 (e+1))) v,
end

theorem capture (v: ℕ) (q : ℕ) : id (λ (e:ℕ), (andFuns (existsFuns (λ x:ℕ, test3 x)) test) (e+q)) v :=
begin
    split_lambda,
    --change
    --    andFuns (existsFuns (λ (y e:ℕ), test3 y (e+q)))
    --            (λ (e:ℕ), test (e + q)) v,
end

example (p q : ℕ → Prop) : (∃ x, p x) → ∃ x, p x ∨ q x :=
begin
  intro h,
  cases h with x px,
  constructor, left, exact px
end

theorem testit: ∀ q, ((λ (f : (ℕ → ℕ)), (λ (x:ℕ), (f x)+(f x)))
                         (λ (x:ℕ), x+1)) q = 2*q+2 :=
begin
sorry
end

theorem testdummy: ∀ a b, a → b :=
begin
    intros, have h:1+1=3 → b, admit, apply h, clear h,
end

theorem assignInExists3 {t:Type} :

 ∀ (s : t → absState) (vv:ℕ) (v:ident),

   ((λ (vv : ℕ) (st:imp_state),
       (@absExists t (λ (x:t), s x)) (st.fst,override st.snd v vv)))
   =
                   (λ (vv : ℕ), (@absExists t (λ (x:t),
                    (λ st, s x (st.fst,override st.snd v vv))))):= sorry.

theorem assignInExists1 {t:Type} :
 ∀ (s : absState) (st2 : imp_state) vv v,
   ((λ (st:imp_state), (@absExists t (λ v, s)) (st.fst,override st.snd v vv))=
                   (@absExists t (λ x, (λ st, s (st.fst,override st.snd v vv))))):= sorry.

theorem stsimp1 : ∀ (v:ident) (vv:ℕ),
    (λ (vv : ℕ) (st : imp_state),
            absExists (λ (x : Value), absTree (λ (env : env), env RR) 2 [0, 1] x)
              (st.fst, override (st.snd) v vv))=
            (λ (vv : ℕ), absExists (λ (x : Value), (λ (st : imp_state), absTree (λ (env : env), env RR) 2 [0, 1] x
              (st.fst, override (st.snd) v vv))) := sorry.

open tactic
open monad
open expr
open smt_tactic

meta def findd : expr → list expr → tactic expr
| e [] := failed
| e (h::hs) :=
    do t ← infer_type h,
    (unify e t >> return h) <|> find e hs.

meta def assumptionn : tactic unit :=
do { ctx ← local_context,
       t ← target,
       h ← findd t ctx,
       exact h }
   <|> fail "assumption tactic failed".

--def g (x:ℕ) := (x+2)
--def f (x:ℕ) := (x+1)


import Iris.BI
import Iris.Proofmode

namespace Iris.Tests
open Iris.BI

/- This file contains tests with various scenarios for all available tactics. -/

-- start stop
theorem start_stop [BI PROP] (Q : PROP) (H : Q ⊢ Q) : Q ⊢ Q := by
  istart
  iintro HQ
  istop
  exact H

-- rename
namespace rename

theorem rename [BI PROP] (Q : PROP) : Q ⊢ Q := by
  iintro HQ
  irename HQ to H
  iexact H

theorem rename_twice [BI PROP] (Q : PROP) : Q ⊢ Q := by
  iintro HQ
  irename HQ to H
  irename H to HQ
  iexact HQ

theorem rename_id [BI PROP] (Q : PROP) : Q ⊢ Q := by
  iintro HQ
  irename HQ to HQ
  iexact HQ

end rename

-- clear
namespace clear

theorem intuitionistic [BI PROP] (Q : PROP) : □ P ⊢ Q -∗ Q := by
  iintro □HP
  iintro HQ
  iclear HP
  iexact HQ

theorem spatial [BI PROP] (Q : PROP) : <affine> P ⊢ Q -∗ Q := by
  iintro HP
  iintro HQ
  iclear HP
  iexact HQ

end clear

-- intro
namespace intro

theorem spatial [BI PROP] (Q : PROP) : Q ⊢ Q := by
  iintro HQ
  iexact HQ

theorem intuitionistic [BI PROP] (Q : PROP) : □ Q ⊢ Q := by
  iintro □HQ
  iexact HQ

theorem as_intuitionistic [BI PROP] (Q : PROP) : <affine> <pers> Q ⊢ Q := by
  iintro □HQ
  iexact HQ

theorem as_intuitionistic_in_spatial [BI PROP] (Q : PROP) : ⊢ <pers> Q → Q := by
  iintro HQ
  iexact HQ

theorem drop [BI PROP] (Q : PROP) : ⊢ P → Q -∗ Q := by
  iintro _ HQ
  iexact HQ

theorem drop_after [BI PROP] (Q : PROP) : ⊢ Q -∗ P → Q := by
  iintro HQ _
  iexact HQ

theorem «forall» [BI PROP] : ⊢ ∀ x, ⌜x = 0⌝ → (⌜x = 0⌝ : PROP) := by
  iintro ⌜x⌝
  iintro H
  iexact H

theorem pure [BIAffine PROP] (Q : PROP) : ⊢ ⌜φ⌝ -∗ Q -∗ Q := by
  iintro ⌜Hφ⌝ HQ
  iexact HQ

theorem pattern [BI PROP] (Q : PROP) : □ (P1 ∨ P2) ∗ Q ⊢ Q := by
  iintro ⟨□(HP1 | HP2), HQ⟩
  <;> iexact HQ

theorem multiple_spatial [BI PROP] (Q : PROP) : ⊢ <affine> P -∗ Q -∗ Q := by
  iintro HP HQ
  iexact HQ

theorem multiple_intuitionistic [BI PROP] (Q : PROP) : ⊢ □ P -∗ □ Q -∗ Q := by
  iintro □HP □HQ
  iexact HQ

theorem multiple_patterns [BI PROP] (Q : PROP) : ⊢ □ (P1 ∧ P2) -∗ Q ∨ Q -∗ Q := by
  iintro □⟨HP1, -□HP2⟩ (HQ | HQ)
  <;> iexact HQ

end intro

-- exist
namespace exist

theorem id [BI PROP] : ⊢ (∃ x, x : PROP) := by
  iexists `[iprop| True]
  ipure_intro
  exact True.intro

theorem f [BI PROP] : ⊢ (∃ (_x : Nat), True ∨ False : PROP) := by
  iexists 42
  ileft
  ipure_intro
  exact True.intro

theorem pure [BI PROP] : ⊢ (⌜∃ x, x ∨ False⌝ : PROP) := by
  iexists True
  ipure_intro
  exact Or.inl True.intro

end exist

-- exact
namespace exact

theorem exact [BI PROP] (Q : PROP) : Q ⊢ Q := by
  iintro HQ
  iexact HQ

theorem def_eq [BI PROP] (Q : PROP) : <affine> <pers> Q ⊢ □ Q := by
  iintro HQ
  iexact HQ

theorem intuitionistic [BI PROP] (Q : PROP) : □ Q ⊢ Q := by
  iintro HQ
  iexact HQ

end exact

-- assumption
namespace assumption

theorem exact [BI PROP] (Q : PROP) : Q ⊢ Q := by
  iintro HQ
  iassumption

theorem from_assumption [BI PROP] (Q : PROP) : <affine> <pers> Q ⊢ □ Q := by
  iintro HQ
  iassumption

theorem intuitionistic [BI PROP] (Q : PROP) : □ Q ⊢ Q := by
  iintro □HQ
  iassumption

theorem lean [BI PROP] (Q : PROP) (H : ⊢ Q) : <affine> P ⊢ Q := by
  iintro HP
  iassumption

theorem lean_pure [BI PROP] (Q : PROP) : <affine> ⌜⊢ Q⌝ ⊢ Q := by
  iintro ⌜H⌝
  iassumption

theorem false [BI PROP] (Q : PROP) : False ⊢ Q := by
  iintro H
  iassumption

end assumption

-- ex falso
namespace exfalso

theorem false [BI PROP] (P : PROP) : □ P ⊢ False -∗ Q := by
  iintro HP HF
  iex_falso
  iexact HF

theorem pure [BI PROP] (P : PROP) (HF : False) : ⊢ P := by
  istart
  iex_falso
  ipure_intro
  exact HF

end exfalso

-- pure
namespace pure

theorem move [BI PROP] (Q : PROP) : <affine> ⌜φ⌝ ⊢ Q -∗ Q := by
  iintro Hφ
  iintro HQ
  ipure Hφ
  iexact HQ

theorem move_multiple [BI PROP] (Q : PROP) : <affine> ⌜φ1⌝ ⊢ <affine> ⌜φ2⌝ -∗ Q -∗ Q := by
  iintro Hφ1
  iintro Hφ2
  iintro HQ
  ipure Hφ1
  ipure Hφ2
  iexact HQ

theorem move_conjunction [BI PROP] (Q : PROP) : (⌜φ1⌝ ∧ <affine> ⌜φ2⌝) ⊢ Q -∗ Q := by
  iintro Hφ
  iintro HQ
  ipure Hφ
  iexact HQ

end pure

-- intuitionistic
namespace intuitionistic

theorem move [BI PROP] (P : PROP) : □ P ⊢ Q -∗ Q := by
  iintro HP
  iintro HQ
  iintuitionistic HP
  iexact HQ

theorem move_multiple [BI PROP] (P : PROP) : □ P ⊢ □ Q -∗ Q := by
  iintro HP
  iintro HQ
  iintuitionistic HP
  iintuitionistic HQ
  iexact HQ

theorem move_twice [BI PROP] (P : PROP) : □ P ⊢ Q -∗ Q := by
  iintro HP
  iintro HQ
  iintuitionistic HP
  iintuitionistic HP
  iexact HQ

end intuitionistic

-- spatial
namespace spatial

theorem move [BI PROP] (P : PROP) : □ P ⊢ □ Q -∗ Q := by
  iintro □HP
  iintro □HQ
  ispatial HP
  iexact HQ

theorem move_multiple [BI PROP] (P : PROP) : □ P ⊢ □ Q -∗ Q := by
  iintro □HP
  iintro □HQ
  ispatial HP
  ispatial HQ
  iexact HQ

theorem move_twice [BI PROP] (P : PROP) : □ P ⊢ □ Q -∗ Q := by
  iintro □HP
  iintro □HQ
  ispatial HP
  ispatial HP
  iexact HQ

end spatial

-- emp intro
namespace empintro

theorem simple [BI PROP] : ⊢ (emp : PROP) := by
  iemp_intro

theorem affine_env [BI PROP] (P : PROP) : <affine> P ⊢ emp := by
  iintro HP
  iemp_intro

end empintro

-- pure intro
namespace pureintro

theorem simple [BI PROP] : ⊢ (⌜True⌝ : PROP) := by
  ipure_intro
  exact True.intro

theorem or [BI PROP] : ⊢ True ∨ (False : PROP) := by
  ipure_intro
  apply Or.inl True.intro

theorem with_proof [BI PROP] (H : A → B) (P Q : PROP) : <affine> P ⊢ <pers> Q → ⌜A⌝ → ⌜B⌝ := by
  iintro HP □HQ
  ipure_intro
  exact H

end pureintro

-- specialize
namespace specialize

theorem wand_spatial [BI PROP] (Q : PROP) : P ⊢ (P -∗ Q) -∗ Q := by
  iintro HP HPQ
  ispecialize HPQ HP as HQ
  iexact HQ

theorem wand_intuitionistic [BI PROP] (Q : PROP) : □ P ⊢ □ (P -∗ Q) -∗ □ Q := by
  iintro □HP □HPQ
  ispecialize HPQ HP as HQ
  iexact HQ

theorem wand_intuitionistic_overwrite [BI PROP] (Q : PROP) : □ P ⊢ □ (□ P -∗ Q) -∗ □ Q := by
  iintro □HP □HPQ
  ispecialize HPQ HP as HPQ
  iexact HPQ

theorem wand_intuitionistic_required [BI PROP] (Q : PROP) : □ P ⊢ □ (□ P -∗ Q) -∗ □ Q := by
  iintro □HP □HPQ
  ispecialize HPQ HP as HQ
  iexact HQ

theorem wand_intuitionistic_spatial [BI PROP] (Q : PROP) : □ P ⊢ (P -∗ Q) -∗ Q := by
  iintro □HP HPQ
  ispecialize HPQ HP as HQ
  iexact HQ

theorem wand_intuitionistic_required_spatial [BI PROP] (Q : PROP) : □ P ⊢ (□ P -∗ Q) -∗ Q := by
  iintro □HP HPQ
  ispecialize HPQ HP as HQ
  iexact HQ

theorem wand_spatial_intuitionistic [BI PROP] (Q : PROP) : P ⊢ □ (P -∗ Q) -∗ Q := by
  iintro HP □HPQ
  ispecialize HPQ HP as HQ
  iexact HQ

theorem wand_spatial_multiple [BI PROP] (Q : PROP) : ⊢ P1 -∗ P2 -∗ (P1 -∗ P2 -∗ Q) -∗ Q := by
  iintro HP1 HP2 HPQ
  ispecialize HPQ HP1 HP2 as HQ
  iexact HQ

theorem wand_intuitionistic_multiple [BI PROP] (Q : PROP) : ⊢ □ P1 -∗ □ P2 -∗ □ (P1 -∗ □ P2 -∗ Q) -∗ □ Q := by
  iintro □HP1 □HP2 □HPQ
  ispecialize HPQ HP1 HP2 as HQ
  iexact HQ

theorem wand_multiple [BI PROP] (Q : PROP) : ⊢ P1 -∗ □ P2 -∗ P3 -∗ □ (P1 -∗ P2 -∗ P3 -∗ Q) -∗ Q := by
  iintro HP1 □HP2 HP3 HPQ
  ispecialize HPQ HP1 HP2 HP3 as HQ
  iexact HQ

theorem forall_spatial [BI PROP] (Q : Nat → PROP) : ⊢ (∀ x, Q x) -∗ Q y := by
  iintro HQ
  ispecialize HQ y as HQ
  iexact HQ

theorem forall_intuitionistic [BI PROP] (Q : Nat → PROP) : ⊢ □ (∀ x, Q x) -∗ □ Q y := by
  iintro □HQ
  ispecialize HQ y as HQ'
  iexact HQ'

theorem forall_intuitionistic_overwrite [BI PROP] (Q : Nat → PROP) : ⊢ □ (∀ x, Q x) -∗ □ Q y := by
  iintro □HQ
  ispecialize HQ y as HQ
  iexact HQ

theorem forall_spatial_intuitionistic [BI PROP] (Q : Nat → PROP) : ⊢ (∀ x, □ Q x) -∗ □ Q y := by
  iintro HQ
  ispecialize HQ y as HQ
  iexact HQ

theorem forall_spatial_multiple [BI PROP] (Q : Nat → Nat → PROP) : ⊢ (∀ x, ∀ y, Q x y) -∗ Q x y := by
  iintro HQ
  ispecialize HQ x y as HQ'
  iexact HQ'

theorem forall_intuitionistic_multiple [BI PROP] (Q : Nat → Nat → PROP) : ⊢ □ (∀ x, ∀ y, Q x y) -∗ □ Q x y := by
  iintro □HQ
  ispecialize HQ x y as HQ'
  iexact HQ'

theorem forall_multiple [BI PROP] (Q : Nat → Nat → PROP) : ⊢ (∀ x, □ (∀ y, Q x y)) -∗ □ Q x y := by
  iintro HQ
  ispecialize HQ x y as HQ'
  iexact HQ'

theorem multiple [BI PROP] (Q : Nat → PROP) : ⊢ □ P1 -∗ P2 -∗ (□ P1 -∗ (∀ x, P2 -∗ Q x)) -∗ Q y := by
  iintro □HP1 HP2 HPQ
  ispecialize HPQ HP1 y HP2 as HQ
  iexact HQ

end specialize

-- split
namespace split

theorem and [BI PROP] (Q : PROP) : Q ⊢ Q ∧ Q := by
  iintro HQ
  isplit
  <;> iexact HQ

theorem sep_left [BIAffine PROP] (Q : PROP) : ⊢ P -∗ Q -∗ R -∗ P ∗ Q := by
  iintro HP
  iintro HQ
  iintro HR
  isplit l [HP]
  · iexact HP
  · iexact HQ

theorem sep_right [BIAffine PROP] (Q : PROP) : ⊢ P -∗ Q -∗ R -∗ P ∗ Q := by
  iintro HP
  iintro HQ
  iintro HR
  isplit r [HQ]
  · iexact HP
  · iexact HQ

theorem sep_left_all [BIAffine PROP] (Q : PROP) : ⊢ P -∗ □ Q -∗ R -∗ P ∗ Q := by
  iintro HP
  iintro □HQ
  iintro HR
  isplit l
  · iexact HP
  · iexact HQ

theorem sep_right_all [BIAffine PROP] (Q : PROP) : ⊢ □ P -∗ Q -∗ R -∗ P ∗ Q := by
  iintro □HP
  iintro HQ
  iintro HR
  isplit r
  · iexact HP
  · iexact HQ

end split

-- left / right
namespace leftright

theorem left [BI PROP] (P : PROP) : P ⊢ P ∨ Q := by
  iintro HP
  ileft
  iexact HP

theorem right [BI PROP] (Q : PROP) : Q ⊢ P ∨ Q := by
  iintro HQ
  iright
  iexact HQ

theorem complex [BI PROP] (P Q : PROP) : ⊢ P -∗ Q -∗ P ∗ (R ∨ Q ∨ R) := by
  iintro HP HQ
  isplit l [HP]
  · iassumption
  iright
  ileft
  iexact HQ

end leftright

-- cases
namespace cases

theorem rename [BI PROP] (P : PROP) : P ⊢ P := by
  iintro HP
  icases HP with H
  iexact H

theorem clear [BI PROP] (P Q : PROP) : ⊢ P -∗ <affine> Q -∗ P := by
  iintro HP
  iintro HQ
  icases HQ with _
  iexact HP

theorem and [BI PROP] (Q : PROP) : □ (P1 ∧ P2 ∧ Q) ⊢ Q := by
  iintro □HP
  icases HP with ⟨HP1, HP2, HQ⟩
  iexact HQ

theorem and_intuitionistic [BI PROP] (Q : PROP) : □ P ∧ Q ⊢ Q := by
  iintro HPQ
  icases HPQ with ⟨HP, HQ⟩
  iexact HQ

theorem and_persistent_left [BI PROP] (Q : PROP) : <pers> Q ∧ <affine> P ⊢ Q := by
  iintro HQP
  icases HQP with ⟨□HQ, HP⟩
  iexact HQ

theorem and_persistent_right [BI PROP] (Q : PROP) : Q ∧ <pers> P ⊢ Q := by
  iintro HQP
  icases HQP with ⟨HQ, HP⟩
  iexact HQ

theorem sep [BIAffine PROP] (Q : PROP) : P1 ∗ P2 ∗ Q ⊢ Q := by
  iintro HPQ
  icases HPQ with ⟨HP1, HP2, HQ⟩
  iexact HQ

theorem disjunction [BI PROP] (Q : PROP) : Q ⊢ <affine> (P1 ∨ P2 ∨ P3) -∗ Q := by
  iintro HQ
  iintro HP
  icases HP with (HP1 | HP2 | HP3)
  <;> iexact HQ

theorem conjunction_and_disjunction [BIAffine PROP] (Q : PROP) : (P11 ∨ P12 ∨ P13) ∗ P2 ∗ (P31 ∨ P32 ∨ P33) ∗ Q ⊢ Q := by
  iintro HP
  icases HP with ⟨HP11 | HP12 | HP13, HP2, HP31 | HP32 | HP33, HQ⟩
  <;> iexact HQ

theorem move_to_pure [BI PROP] (Q : PROP) : ⊢ <affine> ⌜⊢ Q⌝ -∗ Q := by
  iintro HQ
  icases HQ with ⌜HQ⌝
  istop
  exact HQ

theorem move_to_pure_ascii [BI PROP] (Q : PROP) : ⊢ <affine> ⌜⊢ Q⌝ -∗ Q := by
  iintro HQ
  icases HQ with %HQ
  istop
  exact HQ

theorem move_to_intuitionistic [BI PROP] (Q : PROP) : ⊢ □ Q -∗ Q := by
  iintro HQ
  icases HQ with □HQ
  iexact HQ

theorem move_to_intuitionistic_ascii [BI PROP] (Q : PROP) : ⊢ □ Q -∗ Q := by
  iintro HQ
  icases HQ with #HQ
  iexact HQ

theorem move_to_spatial [BI PROP] (Q : PROP) : ⊢ □ Q -∗ Q := by
  iintro □HQ
  icases HQ with -□HQ
  iexact HQ

theorem move_to_spatial_ascii [BI PROP] (Q : PROP) : ⊢ □ Q -∗ Q := by
  iintro □HQ
  icases HQ with -#HQ
  iexact HQ

theorem move_to_pure_conjunction [BI PROP] (Q : PROP) : ⊢ <affine> ⌜φ⌝ ∗ Q -∗ Q := by
  iintro HφQ
  icases HφQ with ⟨⌜Hφ⌝, HQ⟩
  iexact HQ

theorem move_to_pure_disjunction [BI PROP] (Q : PROP) : ⊢ <affine> ⌜φ1⌝ ∨ <affine> ⌜φ2⌝ -∗ Q -∗ Q := by
  iintro Hφ
  iintro HQ
  icases Hφ with (⌜Hφ1⌝ | ⌜Hφ2⌝)
  <;> iexact HQ

theorem move_to_intuitionistic_conjunction [BI PROP] (Q : PROP) : ⊢ □ P ∗ Q -∗ Q := by
  iintro HPQ
  icases HPQ with ⟨□HP, HQ⟩
  iexact HQ

theorem move_to_intuitionistic_disjunction [BI PROP] (Q : PROP) : ⊢ □ Q ∨ Q -∗ Q := by
  iintro HQQ
  icases HQQ with (□HQ | HQ)
  <;> iexact HQ

theorem move_to_spatial_conjunction [BI PROP] (Q : PROP) : ⊢ □ (P ∧ Q) -∗ Q := by
  iintro □HPQ
  icases HPQ with ⟨HP, -□HQ⟩
  iexact HQ

theorem move_to_spatial_disjunction [BI PROP] (Q : PROP) : ⊢ □ (Q ∨ Q) -∗ Q := by
  iintro □HPQ
  icases HPQ with (HQ | -□HQ)
  <;> iexact HQ

theorem move_to_intuitionistic_and_back_conjunction [BI PROP] (Q : PROP) : ⊢ □ (P ∧ Q) -∗ Q := by
  iintro HPQ
  icases HPQ with □⟨HP, -□HQ⟩
  iexact HQ

theorem move_to_intuitionistic_and_back_disjunction [BI PROP] (Q : PROP) : ⊢ □ (Q ∨ Q) -∗ Q := by
  iintro HPQ
  icases HPQ with □(HQ | -□HQ)
  <;> iexact HQ

theorem conjunction_clear [BIAffine PROP] (Q : PROP) : Q ∗ P ⊢ Q := by
  iintro HQP
  icases HQP with ⟨HQ, _⟩
  <;> iexact HQ

theorem disjunction_clear [BIAffine PROP] (Q : PROP) : Q ⊢ P1 ∨ P2 -∗ Q := by
  iintro HQ
  iintro HP
  icases HP with (_ | HP2)
  <;> iexact HQ

theorem and_destruct_spatial_right [BI PROP] (Q : PROP) : P ∧ Q ⊢ Q := by
  iintro HPQ
  icases HPQ with ⟨_, HQ⟩
  iexact HQ

theorem and_destruct_spatial_left [BI PROP] (Q : PROP) : Q ∧ P ⊢ Q := by
  iintro HQP
  icases HQP with ⟨HQ, _⟩
  iexact HQ

theorem and_clear_spatial_multiple [BI PROP] (Q : PROP) : P1 ∧ P2 ∧ Q ∧ P3 ⊢ Q := by
  iintro HPQ
  icases HPQ with ⟨_, _, HQ, _⟩
  iexact HQ

theorem and_destruct_intuitionistic_right [BI PROP] (Q : PROP) : □ (P ∧ Q) ⊢ Q := by
  iintro □HPQ
  icases HPQ with ⟨_, HQ⟩
  iexact HQ

theorem and_destruct_intuitionistic_left [BI PROP] (Q : PROP) : □ (Q ∧ P) ⊢ Q := by
  iintro □HQP
  icases HQP with ⟨HQ, _⟩
  iexact HQ

theorem and_clear_intuitionistic_multiple [BI PROP] (Q : PROP) : □ (P1 ∧ P2 ∧ Q ∧ P3) ⊢ Q := by
  iintro □HPQ
  icases HPQ with ⟨_, _, HQ, _⟩
  iexact HQ

theorem exist [BI PROP] (Q : Nat → PROP) : (∃ x, Q x) ⊢ ∃ x, Q x ∨ False := by
  iintro ⟨x, H⟩
  iexists x
  ileft
  iexact H

theorem exist_intuitionistic [BI PROP] (Q : Nat → PROP) : □ (∃ x, Q x) ⊢ ∃ x, □ Q x ∨ False := by
  iintro ⟨x, □H⟩
  iexists x
  ileft
  iexact H

end cases
end Iris.Tests


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import algebra.order.ring.defs
import algebra.ring.pi
import tactic.positivity

/-!
# Pi instances for ordered groups and monoids

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

This file defines instances for ordered group, monoid, and related structures on Pi types.
-/

universes u v w
variables {ι α β : Type*}
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

namespace pi

/-- The product of a family of ordered commutative monoids is an ordered commutative monoid. -/
@[to_additive "The product of a family of ordered additive commutative monoids is
  an ordered additive commutative monoid."]
instance ordered_comm_monoid {ι : Type*} {Z : ι → Type*} [∀ i, ordered_comm_monoid (Z i)] :
  ordered_comm_monoid (Π i, Z i) :=
{ mul_le_mul_left := λ f g w h i, mul_le_mul_left' (w i) _,
  ..pi.partial_order,
  ..pi.comm_monoid, }

@[to_additive] instance {ι : Type*} {α : ι → Type*} [Π i, has_le (α i)] [Π i, has_mul (α i)]
  [Π i, has_exists_mul_of_le (α i)] :
  has_exists_mul_of_le (Π i, α i) :=
⟨λ a b h, ⟨λ i, (exists_mul_of_le $ h i).some, funext $ λ i, (exists_mul_of_le $ h i).some_spec⟩⟩

/-- The product of a family of canonically ordered monoids is a canonically ordered monoid. -/
@[to_additive "The product of a family of canonically ordered additive monoids is
  a canonically ordered additive monoid."]
instance {ι : Type*} {Z : ι → Type*} [∀ i, canonically_ordered_monoid (Z i)] :
  canonically_ordered_monoid (Π i, Z i) :=
{ le_self_mul := λ f g i, le_self_mul,
  ..pi.order_bot, ..pi.ordered_comm_monoid, ..pi.has_exists_mul_of_le }

@[to_additive]
instance ordered_cancel_comm_monoid [∀ i, ordered_cancel_comm_monoid $ f i] :
  ordered_cancel_comm_monoid (Π i : I, f i) :=
by refine_struct { mul := (*), one := (1 : Π i, f i), le := (≤), lt := (<),
  npow := monoid.npow, .. pi.partial_order, .. pi.monoid };
  tactic.pi_instance_derive_field

@[to_additive]
instance ordered_comm_group [∀ i, ordered_comm_group $ f i] :
  ordered_comm_group (Π i : I, f i) :=
{ mul := (*), one := (1 : Π i, f i), le := (≤), lt := (<),
  npow := monoid.npow,
  ..pi.comm_group,
  ..pi.ordered_comm_monoid, }

instance [Π i, ordered_semiring (f i)] : ordered_semiring (Π i, f i) :=
{ add_le_add_left := λ a b hab c i, add_le_add_left (hab _) _,
  zero_le_one := λ _, zero_le_one,
  mul_le_mul_of_nonneg_left := λ a b c hab hc i, mul_le_mul_of_nonneg_left (hab _) $ hc _,
  mul_le_mul_of_nonneg_right := λ a b c hab hc i, mul_le_mul_of_nonneg_right (hab _) $ hc _,
    ..pi.semiring, ..pi.partial_order }

instance [Π i, ordered_comm_semiring (f i)] : ordered_comm_semiring (Π i, f i) :=
{ ..pi.comm_semiring, ..pi.ordered_semiring }

instance [Π i, ordered_ring (f i)] : ordered_ring (Π i, f i) :=
{ mul_nonneg := λ a b ha hb i, mul_nonneg (ha _) (hb _),
    ..pi.ring, ..pi.ordered_semiring }

instance [Π i, ordered_comm_ring (f i)] : ordered_comm_ring (Π i, f i) :=
{ ..pi.comm_ring, ..pi.ordered_ring }

end pi

namespace function
variables (β) [has_one α] [preorder α] {a : α}

@[to_additive const_nonneg_of_nonneg]
lemma one_le_const_of_one_le (ha : 1 ≤ a) : 1 ≤ const β a := λ _, ha

@[to_additive] lemma const_le_one_of_le_one (ha : a ≤ 1) : const β a ≤ 1 := λ _, ha

variables {β} [nonempty β]

@[simp, to_additive const_nonneg]
lemma one_le_const : 1 ≤ const β a ↔ 1 ≤ a := @const_le_const _ _ _ _ 1 _
@[simp, to_additive const_pos]
lemma one_lt_const : 1 < const β a ↔ 1 < a := @const_lt_const _ _ _ _ 1 a
@[simp, to_additive] lemma const_le_one : const β a ≤ 1 ↔ a ≤ 1 := @const_le_const _ _ _ _ _ 1
@[simp, to_additive] lemma const_lt_one : const β a < 1 ↔ a < 1 := @const_lt_const _ _ _ _ _ 1

end function

namespace tactic
open function positivity
variables (ι) [has_zero α] {a : α}

private lemma function_const_nonneg_of_pos [preorder α] (ha : 0 < a) : 0 ≤ const ι a :=
const_nonneg_of_nonneg _ ha.le

variables [nonempty ι]

private lemma function_const_ne_zero : a ≠ 0 → const ι a ≠ 0 := const_ne_zero.2
private

/-- Extension for the `positivity` tactic: `function.const` is positive/nonnegative/nonzero if its
input is. -/
@[positivity]
meta def positivity_const : expr → tactic strictness
| `(function.const %%ι %%a) := do
    strict_a ← core a,
    match strict_a with
    | positive p := positive <$> to_expr ``(function_const_pos %%ι %%p)
        <|> nonnegative <$> to_expr ``(function_const_nonneg_of_pos %%ι %%p)
    | nonnegative p := nonnegative <$> to_expr ``(const_nonneg_of_nonneg %%ι %%p)
    | nonzero p := nonzero <$> to_expr ``(function_const_ne_zero %%ι %%p)
    end
| e := pp e >>= fail ∘ format.bracket "The expression `" "` is not of the form `function.const ι a`"

end tactic


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

! This file was ported from Lean 3 source module tactic.reassoc_axiom
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Category.Basic

/-!
# Tools to reformulate category-theoretic axioms in a more associativity-friendly way

## The `reassoc` attribute

The `reassoc` attribute can be applied to a lemma

```lean
@[reassoc]
lemma some_lemma : foo ≫ bar = baz := ...
```

and produce

```lean
lemma some_lemma_assoc {Y : C} (f : X ⟶ Y) : foo ≫ bar ≫ f = baz ≫ f := ...
```

The name of the produced lemma can be specified with `@[reassoc other_lemma_name]`. If
`simp` is added first, the generated lemma will also have the `simp` attribute.

## The `reassoc_axiom` command

When declaring a class of categories, the axioms can be reformulated to be more amenable
to manipulation in right associated expressions:

```lean
class some_class (C : Type) [category C] :=
(foo : Π X : C, X ⟶ X)
(bar : ∀ {X Y : C} (f : X ⟶ Y), foo X ≫ f = f ≫ foo Y)

reassoc_axiom some_class.bar
```

Here too, the `reassoc` attribute can be used instead. It works well when combined with
`simp`:

```lean
attribute [simp, reassoc] some_class.bar
```
-/

namespace Tactic

open CategoryTheory

/-- From an expression `f ≫ g`, extract the expression representing the category instance. -/
unsafe def get_cat_inst : expr → tactic expr
  | q(@CategoryStruct.comp _ $(struct_inst) _ _ _ _ _) => pure struct_inst
  | _ => failed
#align tactic.get_cat_inst tactic.get_cat_inst

/-- (internals for `@[reassoc]`)
Given a lemma of the form `∀ ..., f ≫ g = h`, proves a new lemma of the form
`h : ∀ ... {W} (k), f ≫ (g ≫ k) = h ≫ k`, and returns the type and proof of this lemma.
-/
unsafe def prove_reassoc (h : expr) : tactic (expr × expr) := do
  let (vs, t) ← infer_type h >>= open_pis
  let (lhs, rhs) ← match_eq t
  let struct_inst ←
    get_cat_inst lhs <|> get_cat_inst rhs <|> fail "no composition found in statement"
  let q(@Quiver.Hom _ $(hom_inst) $(X) $(Y)) ← infer_type lhs
  let C ← infer_type X
  let X' ← mk_local' `X' BinderInfo.implicit C
  let ft ← to_expr ``(@Quiver.Hom _ $(hom_inst) $(Y) $(X'))
  let f' ← mk_local_def `f' ft
  let t' ←
    to_expr
        ``(@CategoryStruct.comp _ $(struct_inst) _ _ _ $(lhs) $(f') =
            @CategoryStruct.comp _ $(struct_inst) _ _ _ $(rhs) $(f'))
  let c' := h.mk_app vs
  let (_, pr) ← solve_aux t' (andthen (rewrite_target c') reflexivity)
  let pr ← instantiate_mvars pr
  let s := simp_lemmas.mk
  let s ← s.add_simp `` category.assoc
  let s ← s.add_simp `` category.id_comp
  let s ← s.add_simp `` category.comp_id
  let (t'', pr', _) ← simplify s [] t'
  let pr' ← mk_eq_mp pr' pr
  let t'' ← pis (vs ++ [X', f']) t''
  let pr' ← lambdas (vs ++ [X', f']) pr'
  pure (t'', pr')
#align tactic.prove_reassoc tactic.prove_reassoc

/-- (implementation for `@[reassoc]`)
Given a declaration named `n` of the form `∀ ..., f ≫ g = h`, proves a new lemma named `n'`
of the form `∀ ... {W} (k), f ≫ (g ≫ k) = h ≫ k`.
-/
unsafe def reassoc_axiom (n : Name) (n' : Name := n.appendSuffix "_assoc") : tactic Unit := do
  let d ← get_decl n
  let ls := d.univ_params.map level.param
  let c := @expr.const true n ls
  let (t'', pr') ← prove_reassoc c
  add_decl <| declaration.thm n' d t'' (pure pr')
  copy_attribute `simp n n'
#align tactic.reassoc_axiom tactic.reassoc_axiom

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- The `reassoc` attribute can be applied to a lemma

```lean
@[reassoc]
lemma some_lemma : foo ≫ bar = baz := ...
```

to produce

```lean
lemma some_lemma_assoc {Y : C} (f : X ⟶ Y) : foo ≫ bar ≫ f = baz ≫ f := ...
```

The name of the produced lemma can be specified with `@[reassoc other_lemma_name]`. If
`simp` is added first, the generated lemma will also have the `simp` attribute.
-/
@[user_attribute]
unsafe def reassoc_attr : user_attribute Unit (Option Name)
    where
  Name := `reassoc
  descr := "create a companion lemma for associativity-aware rewriting"
  parser := optional ident
  after_set :=
    some fun n _ _ => do
      let some n' ← reassoc_attr.get_param n |
        reassoc_axiom n (n.appendSuffix "_assoc")
      reassoc_axiom n <| n ++ n'
#align tactic.reassoc_attr tactic.reassoc_attr

add_tactic_doc
  { Name := "reassoc"
    category := DocCategory.attr
    declNames := [`tactic.reassoc_attr]
    tags := ["category theory"] }

/-- When declaring a class of categories, the axioms can be reformulated to be more amenable
to manipulation in right associated expressions:

```lean
class some_class (C : Type) [category C] :=
(foo : Π X : C, X ⟶ X)
(bar : ∀ {X Y : C} (f : X ⟶ Y), foo X ≫ f = f ≫ foo Y)

reassoc_axiom some_class.bar
```

The above will produce:

```lean
lemma some_class.bar_assoc {Z : C} (g : Y ⟶ Z) :
  foo X ≫ f ≫ g = f ≫ foo Y ≫ g := ...
```

Here too, the `reassoc` attribute can be used instead. It works well when combined with
`simp`:

```lean
attribute [simp, reassoc] some_class.bar
```
-/
@[user_command]
unsafe def reassoc_cmd (_ : parse <| tk "reassoc_axiom") : lean.parser Unit := do
  let n ← ident
  of_tactic do
      let n ← resolve_constant n
      reassoc_axiom n
#align tactic.reassoc_cmd tactic.reassoc_cmd

add_tactic_doc
  { Name := "reassoc_axiom"
    category := DocCategory.cmd
    declNames := [`tactic.reassoc_cmd]
    tags := ["category theory"] }

namespace Interactive

/-- `reassoc h`, for assumption `h : x ≫ y = z`, creates a new assumption
`h : ∀ {W} (f : Z ⟶ W), x ≫ y ≫ f = z ≫ f`.
`reassoc! h`, does the same but deletes the initial `h` assumption.
(You can also add the attribute `@[reassoc]` to lemmas to generate new declarations generalized
in this way.)
-/
unsafe def reassoc (del : parse (tk "!")?) (ns : parse ident*) : tactic Unit := do
  ns fun n => do
      let h ← get_local n
      let (t, pr) ← prove_reassoc h
      assertv n t pr
      when del (tactic.clear h)
#align tactic.interactive.reassoc tactic.interactive.reassoc

end Interactive

def CalculatedProp {α} (β : Prop) (hh : α) :=
  β
#align tactic.calculated_Prop Tactic.CalculatedProp

unsafe def derive_reassoc_proof : tactic Unit := do
  let q(CalculatedProp $(v) $(h)) ← target
  let (t, pr) ← prove_reassoc h
  unify v t
  exact pr
#align tactic.derive_reassoc_proof tactic.derive_reassoc_proof

end Tactic

/-- With `h : x ≫ y ≫ z = x` (with universal quantifiers tolerated),
`reassoc_of h : ∀ {X'} (f : W ⟶ X'), x ≫ y ≫ z ≫ f = x ≫ f`.

The type and proof of `reassoc_of h` is generated by `tactic.derive_reassoc_proof`
which make `reassoc_of` meta-programming adjacent. It is not called as a tactic but as
an expression. The goal is to avoid creating assumptions that are dismissed after one use:

```lean
example (X Y Z W : C) (x : X ⟶ Y) (y : Y ⟶ Z) (z z' : Z ⟶ W) (w : X ⟶ Z)
  (h : x ≫ y = w)
  (h' : y ≫ z = y ≫ z') :
  x ≫ y ≫ z = w ≫ z' :=
begin
  rw [h',reassoc_of h],
end
```
-/
theorem CategoryTheory.reassoc_of {α} (hh : α) {β}
    (x : Tactic.CalculatedProp β hh := by derive_reassoc_proof) : β :=
  x
#align category_theory.reassoc_of CategoryTheory.reassoc_of

/-- `reassoc_of h` takes local assumption `h` and add a ` ≫ f` term on the right of
both sides of the equality. Instead of creating a new assumption from the result, `reassoc_of h`
stands for the proof of that reassociated statement. This keeps complicated assumptions that are
used only once or twice from polluting the local context.

In the following, assumption `h` is needed in a reassociated form. Instead of proving it as a new
goal and adding it as an assumption, we use `reassoc_of h` as a rewrite rule which works just as
well.

```lean
example (X Y Z W : C) (x : X ⟶ Y) (y : Y ⟶ Z) (z z' : Z ⟶ W) (w : X ⟶ Z)
  (h : x ≫ y = w)
  (h' : y ≫ z = y ≫ z') :
  x ≫ y ≫ z = w ≫ z' :=
begin
  -- reassoc_of h : ∀ {X' : C} (f : W ⟶ X'), x ≫ y ≫ f = w ≫ f
  rw [h',reassoc_of h],
end
```

Although `reassoc_of` is not a tactic or a meta program, its type is generated
through meta-programming to make it usable inside normal expressions.
-/
add_tactic_doc
  { Name := "category_theory.reassoc_of"
    category := DocCategory.tactic
    declNames := [`category_theory.reassoc_of]
    tags := ["category theory"] }


import LeanSAT.Encode.EncCNF
import LeanSAT.Solver.Basic

open Std

namespace LeanSAT.Solver.Dimacs

def formatVar : Var → String
| (n : Nat) => s!"{n + 1}"

def formatLit : Literal → String
| .pos v => formatVar v
| .neg v => "-" ++ formatVar v

def formatClause : Clause → String
| ⟨lits⟩ => lits.map (formatLit ·) ++ ["0"] |> String.intercalate " "

def formatFormula (f : Formula) : String :=
  let (vars,clauses) := (f.numVars, f.clauses.length)
  s!"p cnf {vars} {clauses}\n" ++ (
    f.clauses.map formatClause |> String.intercalate "\n" )

def printFormula [Monad m] (print : String → m Unit) (f : Formula) : m Unit := do
  let (vars,clauses) := (f.numVars, f.clauses.length)
  print <| s!"p cnf {vars} {clauses}\n"
  for c in f.clauses do
    print <| formatClause c ++ "\n"

open Notation in
example : (printFormula PrinterM.putStr ((0 ∨ 1) ∧ 5) |>.run) =
"p cnf 6 2
1 2 0
6 0
" := rfl

def formatAssn (a : Assn) : String :=
  a.fold (fun str v b =>
    if b then
      str.append s!" {v}"
    else
      str.append s!" -{v}")
    "v"

def printRes [Monad m] [MonadExcept ε m] [Inhabited ε] (print : String → m Unit) : Solver.Res → m Unit
| .sat assn => do
  print "s SATISFIABLE"
  print (formatAssn assn)
| .unsat => print "s UNSATISFIABLE"
| .error => throw default

def printEnc [Monad m] (print : String → m Unit) (s : Encode.EncCNF.State) : m Unit := do
  for i in [0:s.nextVar] do
    for name in s.names.find? i do
      print s!"c {Dimacs.formatVar i} {name}\n"

  Dimacs.printFormula print ⟨s.clauses.reverse⟩

structure DimacsParseRes where
  vars : Nat
  clauses : List Clause

def parseVar (maxVar : Nat) (s : String) : Except String Var := do
  let n ← s.toNat?.expectSome fun () => s!"Expected variable; got non-Nat: `{s}`"
  match n with
  | 0   => throw s!"Expected variable; got zero: `{s}`"
  | v+1 =>
    if v < maxVar then
      return v
    else
      throw s!"Variable {v} higher than max var {maxVar}"

def parseLit (maxVar : Nat) (s : String) : Except String Literal := do
  if s.startsWith "-" then
    parseVar maxVar (s.drop 1) |>.map Literal.not
  else
    parseVar maxVar s

def parseClause (maxVar : Nat) (s : String) : Except String Clause := do
  let lits ← s.splitOn " " |>.mapM (parseLit maxVar)
  return ⟨lits⟩

def parseHeader (s : String) : Except String (Nat × Nat) := do
  match s.splitOn " " with
  | ["p", "cnf", vars, clauses] => do
    let vars ← vars.toNat?.expectSome     fun () => s!"Header line #vars: expected number, got `{vars}`"
    let clss ← clauses.toNat?.expectSome  fun () => s!"Header line #clauses: expected number, got `{clauses}`"
    return (vars, clss)
  | _ => .error s!"Expected header `p cnf <#vars> <#clauses>`; got `{s}`"

def parseFormula (s : String) : Except String DimacsParseRes := do
  let ⟨pLine, clauseLines⟩ ←
    s.splitOn "\n"
    |>.filter (fun line => !line.startsWith "c" && line.any (!·.isWhitespace))
    |>.expectNonempty fun () => "All lines are empty or comments"
  let (nvars, _) ← parseHeader pLine
  let clauses ← clauseLines.mapM (parseClause nvars)
  return {
    vars := nvars
    clauses := clauses
  }

def parseAssnLine (maxVar : Var) (assn : Assn) (s : String) : Except String Assn := do
  match ← (s.splitOn " " |>.expectNonempty fun () => panic! "splitOn returned empty?? 645") with
  | ⟨"v", vars⟩ => do
    let forAssn ← vars.foldlM (fun assn x => do
      ForInStep.bind assn fun assn => do
        if x = "0" then
          return ForInStep.done assn
        else
          let l ← parseLit maxVar x
          return ForInStep.yield <| assn.insertLit l
    ) (ForInStep.yield assn)
    return ForInStep.run forAssn
  | _ =>
    .error s!"Expected `v <lits>`, got `{s}`"

def parseResult (maxVar : Var) (s : String) : Except String Solver.Res := do
  let lines :=
    s.splitOn "\n"
    |>.filter (fun line => !line.startsWith "c" && line.any (!·.isWhitespace))
  match ←(lines.expectNonempty fun () => s!"Expected result, got `{s}`") with
  | ⟨first, rest⟩ =>
  match first with
  | "s UNSATISFIABLE" => return .unsat
  | "s SATISFIABLE" =>
    let assn ←
      rest.foldlM (fun assn line => parseAssnLine maxVar assn line) (HashMap.empty)
    return .sat assn
  | _ => .error  "Expected `s <UNSATISFIABLE|SATISFIABLE>`, got `{first}`"

def fromFileEnc (cnfFile : String) : IO Encode.EncCNF.State := do
  let contents ← IO.FS.withFile cnfFile .read (·.readToEnd)
  let {vars, clauses} ← IO.ofExcept <| Dimacs.parseFormula contents
  return {
    nextVar := vars
    clauses := clauses
    names := Id.run do
      let mut map : HashMap Var String := HashMap.empty
      for i in [0:vars] do
        map := map.insert i s!"DIMACS var {i}"
      return map
    varCtx := ""
  }


universe u v

inductive Imf {α : Type u} {β : Type v} (f : α → β) : β → Type (max u v)
| mk : (a : α) → Imf f (f a)

def h {α β} {f : α → β} : {b : β} → Imf f b → α
| _, Imf.mk a => a

#print h
infix:50 " ≅ "  => HEq
theorem ex : ∀ {α β : Sort u} (h : α = β) (a : α), cast h a ≅ a
  | α, _, rfl, a => HEq.refl a

#print ex


import ground_zero.HITs.truncation
open ground_zero

namespace ground_zero.mere_eq_lemma
universe u

def to_mere_eq {α β : Sort u} (h : α = β) : ∥α = β :> Sort u∥ :=
begin induction h, apply ground_zero.HITs.truncation.elem, reflexivity end

def from_mere_eq {α β : Sort u} : ∥α = β :> Sort u∥ → α = β :=
HITs.truncation.rec structures.prop_impl_prop
  (begin intro x, induction x, reflexivity end)

lemma mere_eq {α β : Sort u} : (α = β) ≃ ∥α = β :> Sort u∥ := begin
  existsi to_mere_eq, split; existsi from_mere_eq,
  { trivial },
  { intro h, simp, apply HITs.truncation.uniq }
end

end ground_zero.mere_eq_lemma


import category_theory.equivalence

open category_theory

variables {C : Type*} [category C]
variables {D : Type*} [category D]

lemma equiv_preserves_mono {X Y : C} (f : X ⟶ Y) [mono f] (e : C ≌ D) :
  mono (e.functor.map f) :=
begin
  tidy,
  replace w := congr_arg (λ k, e.inverse.map k) w,
  simp at w,
  -- We can see that `w` is now in a position that we can use the hyothesis `mono f`.
  -- However there's a problem, which is that `A ≫ B ≫ C` is implicitly right-associated,
  -- so we can't directly use `rw cancel_mono f at w`.
  -- We first need to shuffle the parentheses around using associativity:
  rw [←category.assoc] at w, -- and maybe a second time?
  sorry
end


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

universes u v

namespace Mathlib

namespace smt

def array (α : Type u) (β : Type v) := α → β

def select {α : Type u} {β : Type v} (a : array α β) (i : α) : β := a i

theorem arrayext {α : Type u} {β : Type v} (a₁ : array α β) (a₂ : array α β) :
    (∀ (i : α), select a₁ i = select a₂ i) → a₁ = a₂ :=
  funext

def store {α : Type u} {β : Type v} [DecidableEq α] (a : array α β) (i : α) (v : β) : array α β :=
  fun (j : α) => ite (j = i) v (select a j)

@[simp] theorem select_store {α : Type u} {β : Type v} [DecidableEq α] (a : array α β) (i : α)
    (v : β) : select (store a i v) i = v :=
  sorry

@[simp] theorem select_store_ne {α : Type u} {β : Type v} [DecidableEq α] (a : array α β) (i : α)
    (j : α) (v : β) : j ≠ i → select (store a i v) j = select a j :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Group.basic
import Mathlib.data.equiv.ring
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Category instances for semiring, ring, comm_semiring, and comm_ring.

We introduce the bundled categories:
* `SemiRing`
* `Ring`
* `CommSemiRing`
* `CommRing`
along with the relevant forgetful functors between them.
-/

/-- The category of semirings. -/
def SemiRing := category_theory.bundled semiring

namespace SemiRing

protected instance bundled_hom : category_theory.bundled_hom ring_hom :=
  category_theory.bundled_hom.mk ring_hom.to_fun ring_hom.id ring_hom.comp

protected instance large_category : category_theory.large_category SemiRing :=
  category_theory.bundled_hom.category ring_hom

/-- Construct a bundled SemiRing from the underlying type and typeclass. -/
def of (R : Type u) [semiring R] : SemiRing := category_theory.bundled.of R

protected instance inhabited : Inhabited SemiRing := { default := of PUnit }

protected instance semiring (R : SemiRing) : semiring ↥R := category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [semiring R] : ↥(of R) = R := rfl

protected instance has_forget_to_Mon : category_theory.has_forget₂ SemiRing Mon :=
  category_theory.bundled_hom.mk_has_forget₂
    (fun (R : Type u_1) (hR : semiring R) => monoid_with_zero.to_monoid R)
    (fun (R₁ R₂ : category_theory.bundled semiring) => ring_hom.to_monoid_hom) sorry

-- can't use bundled_hom.mk_has_forget₂, since AddCommMon is an induced category

protected instance has_forget_to_AddCommMon : category_theory.has_forget₂ SemiRing AddCommMon :=
  category_theory.has_forget₂.mk
    (category_theory.functor.mk (fun (R : SemiRing) => AddCommMon.of ↥R)
      fun (R₁ R₂ : SemiRing) (f : R₁ ⟶ R₂) => ring_hom.to_add_monoid_hom f)

end SemiRing

/-- The category of rings. -/
def Ring := category_theory.bundled ring

namespace Ring

protected instance ring.to_semiring.category_theory.bundled_hom.parent_projection :
    category_theory.bundled_hom.parent_projection ring.to_semiring :=
  category_theory.bundled_hom.parent_projection.mk

protected instance concrete_category : category_theory.concrete_category Ring :=
  category_theory.bundled_hom.category_theory.bundled.category_theory.concrete_category
    (category_theory.bundled_hom.map_hom ring_hom ring.to_semiring)

/-- Construct a bundled Ring from the underlying type and typeclass. -/
def of (R : Type u) [ring R] : Ring := category_theory.bundled.of R

protected instance inhabited : Inhabited Ring := { default := of PUnit }

protected instance ring (R : Ring) : ring ↥R := category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [ring R] : ↥(of R) = R := rfl

protected instance has_forget_to_SemiRing : category_theory.has_forget₂ Ring SemiRing :=
  category_theory.bundled_hom.forget₂ ring_hom ring.to_semiring

-- can't use bundled_hom.mk_has_forget₂, since AddCommGroup is an induced category

protected instance has_forget_to_AddCommGroup : category_theory.has_forget₂ Ring AddCommGroup :=
  category_theory.has_forget₂.mk
    (category_theory.functor.mk (fun (R : Ring) => AddCommGroup.of ↥R)
      fun (R₁ R₂ : Ring) (f : R₁ ⟶ R₂) => ring_hom.to_add_monoid_hom f)

end Ring

/-- The category of commutative semirings. -/
def CommSemiRing := category_theory.bundled comm_semiring

namespace CommSemiRing

protected instance comm_semiring.to_semiring.category_theory.bundled_hom.parent_projection :
    category_theory.bundled_hom.parent_projection comm_semiring.to_semiring :=
  category_theory.bundled_hom.parent_projection.mk

protected instance large_category : category_theory.large_category CommSemiRing :=
  category_theory.bundled_hom.category
    (category_theory.bundled_hom.map_hom ring_hom comm_semiring.to_semiring)

/-- Construct a bundled CommSemiRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_semiring R] : CommSemiRing := category_theory.bundled.of R

protected instance inhabited : Inhabited CommSemiRing := { default := of PUnit }

protected instance comm_semiring (R : CommSemiRing) : comm_semiring ↥R :=
  category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [comm_semiring R] : ↥(of R) = R := rfl

protected instance has_forget_to_SemiRing : category_theory.has_forget₂ CommSemiRing SemiRing :=
  category_theory.bundled_hom.forget₂ ring_hom comm_semiring.to_semiring

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
protected instance has_forget_to_CommMon : category_theory.has_forget₂ CommSemiRing CommMon :=
  category_theory.has_forget₂.mk' (fun (R : CommSemiRing) => CommMon.of ↥R) sorry
    (fun (R₁ R₂ : CommSemiRing) (f : R₁ ⟶ R₂) => ring_hom.to_monoid_hom f) sorry

end CommSemiRing

/-- The category of commutative rings. -/
def CommRing := category_theory.bundled comm_ring

namespace CommRing

protected instance comm_ring.to_ring.category_theory.bundled_hom.parent_projection :
    category_theory.bundled_hom.parent_projection comm_ring.to_ring :=
  category_theory.bundled_hom.parent_projection.mk

protected instance concrete_category : category_theory.concrete_category CommRing :=
  category_theory.bundled_hom.category_theory.bundled.category_theory.concrete_category
    (category_theory.bundled_hom.map_hom
      (category_theory.bundled_hom.map_hom ring_hom ring.to_semiring) comm_ring.to_ring)

/-- Construct a bundled CommRing from the underlying type and typeclass. -/
def of (R : Type u) [comm_ring R] : CommRing := category_theory.bundled.of R

protected instance inhabited : Inhabited CommRing := { default := of PUnit }

protected instance comm_ring (R : CommRing) : comm_ring ↥R := category_theory.bundled.str R

@[simp] theorem coe_of (R : Type u) [comm_ring R] : ↥(of R) = R := rfl

protected instance has_forget_to_Ring : category_theory.has_forget₂ CommRing Ring :=
  category_theory.bundled_hom.forget₂
    (category_theory.bundled_hom.map_hom ring_hom ring.to_semiring) comm_ring.to_ring

/-- The forgetful functor from commutative rings to (multiplicative) commutative monoids. -/
protected instance has_forget_to_CommSemiRing : category_theory.has_forget₂ CommRing CommSemiRing :=
  category_theory.has_forget₂.mk' (fun (R : CommRing) => CommSemiRing.of ↥R) sorry
    (fun (R₁ R₂ : CommRing) (f : R₁ ⟶ R₂) => f) sorry

protected instance category_theory.forget₂.category_theory.full :
    category_theory.full (category_theory.forget₂ CommRing CommSemiRing) :=
  category_theory.full.mk
    fun (X Y : CommRing)
      (f :
      category_theory.functor.obj (category_theory.forget₂ CommRing CommSemiRing) X ⟶
        category_theory.functor.obj (category_theory.forget₂ CommRing CommSemiRing) Y) =>
      f

end CommRing

-- This example verifies an improvement possible in Lean 3.8.

-- Before that, to have `add_ring_hom.map_zero` usable by `simp` here,

-- we had to mark all the concrete category `has_coe_to_sort` instances reducible.

-- Now, it just works.

namespace ring_equiv

/-- Build an isomorphism in the category `Ring` from a `ring_equiv` between `ring`s. -/
@[simp] theorem to_Ring_iso_inv {X : Type u} {Y : Type u} [ring X] [ring Y] (e : X ≃+* Y) :
    category_theory.iso.inv (to_Ring_iso e) = to_ring_hom (ring_equiv.symm e) :=
  Eq.refl (category_theory.iso.inv (to_Ring_iso e))

/-- Build an isomorphism in the category `CommRing` from a `ring_equiv` between `comm_ring`s. -/
def to_CommRing_iso {X : Type u} {Y : Type u} [comm_ring X] [comm_ring Y] (e : X ≃+* Y) :
    CommRing.of X ≅ CommRing.of Y :=
  category_theory.iso.mk (to_ring_hom e) (to_ring_hom (ring_equiv.symm e))

end ring_equiv

namespace category_theory.iso

/-- Build a `ring_equiv` from an isomorphism in the category `Ring`. -/
def Ring_iso_to_ring_equiv {X : Ring} {Y : Ring} (i : X ≅ Y) : ↥X ≃+* ↥Y :=
  ring_equiv.mk ⇑(hom i) ⇑(inv i) sorry sorry sorry sorry

/-- Build a `ring_equiv` from an isomorphism in the category `CommRing`. -/
def CommRing_iso_to_ring_equiv {X : CommRing} {Y : CommRing} (i : X ≅ Y) : ↥X ≃+* ↥Y :=
  ring_equiv.mk ⇑(hom i) ⇑(inv i) sorry sorry sorry sorry

end category_theory.iso

/-- Ring equivalences between `ring`s are the same as (isomorphic to) isomorphisms in `Ring`. -/
def ring_equiv_iso_Ring_iso {X : Type u} {Y : Type u} [ring X] [ring Y] :
    X ≃+* Y ≅ Ring.of X ≅ Ring.of Y :=
  category_theory.iso.mk (fun (e : X ≃+* Y) => ring_equiv.to_Ring_iso e)
    fun (i : Ring.of X ≅ Ring.of Y) => category_theory.iso.Ring_iso_to_ring_equiv i

/-- Ring equivalences between `comm_ring`s are the same as (isomorphic to) isomorphisms
in `CommRing`. -/
def ring_equiv_iso_CommRing_iso {X : Type u} {Y : Type u} [comm_ring X] [comm_ring Y] :
    X ≃+* Y ≅ CommRing.of X ≅ CommRing.of Y :=
  category_theory.iso.mk (fun (e : X ≃+* Y) => ring_equiv.to_CommRing_iso e)
    fun (i : CommRing.of X ≅ CommRing.of Y) => category_theory.iso.CommRing_iso_to_ring_equiv i

protected instance Ring.forget_reflects_isos :
    category_theory.reflects_isomorphisms (category_theory.forget Ring) :=
  category_theory.reflects_isomorphisms.mk
    fun (X Y : Ring) (f : X ⟶ Y)
      (_x : category_theory.is_iso (category_theory.functor.map (category_theory.forget Ring) f)) =>
      let i :
        category_theory.functor.obj (category_theory.forget Ring) X ≅
          category_theory.functor.obj (category_theory.forget Ring) Y :=
        category_theory.as_iso (category_theory.functor.map (category_theory.forget Ring) f);
      let e : ↥X ≃+* ↥Y :=
        ring_equiv.mk (ring_hom.to_fun f) (equiv.inv_fun (category_theory.iso.to_equiv i)) sorry
          sorry sorry sorry;
      category_theory.is_iso.mk (category_theory.iso.inv (ring_equiv.to_Ring_iso e))

protected instance CommRing.forget_reflects_isos :
    category_theory.reflects_isomorphisms (category_theory.forget CommRing) :=
  category_theory.reflects_isomorphisms.mk
    fun (X Y : CommRing) (f : X ⟶ Y)
      (_x :
      category_theory.is_iso (category_theory.functor.map (category_theory.forget CommRing) f)) =>
      let i :
        category_theory.functor.obj (category_theory.forget CommRing) X ≅
          category_theory.functor.obj (category_theory.forget CommRing) Y :=
        category_theory.as_iso (category_theory.functor.map (category_theory.forget CommRing) f);
      let e : ↥X ≃+* ↥Y :=
        ring_equiv.mk (ring_hom.to_fun f) (equiv.inv_fun (category_theory.iso.to_equiv i)) sorry
          sorry sorry sorry;
      category_theory.is_iso.mk (category_theory.iso.inv (ring_equiv.to_CommRing_iso e))

end Mathlib


inductive HList : List (Type u) → Type (u+1)
  | nil  : HList []
  | cons : α → HList αs → HList (α::αs)

-- Overload `::` notation for HLists
infixr:67 " :: " => HList.cons

-- Overload `[]` notation for HLists
syntax (name := hlist) "[" term,* "]"  : term
macro_rules (kind := hlist)
  | `([ ])           => `(HList.nil)
  | `([ $a ])        => `(HList.cons $a HList.nil)
  | `([ $a, $as,* ]) => `(HList.cons $a [$as,*])

def List.nth : (as : List α) → (i : Fin as.length) → α
  | a::as, ⟨0, _⟩   => a
  | a::as, ⟨i+1, h⟩ => nth as ⟨i, Nat.lt_of_succ_lt_succ h⟩

def HList.nth : HList αs → (n : Fin αs.length) → αs.nth n
  | x::_,  ⟨0, _⟩   => x
  | _::xs, ⟨n+1, h⟩ => xs.nth ⟨n, Nat.lt_of_succ_lt_succ h⟩

def HList.length : HList αs → Nat
  | []    => 0
  | _::xs => xs.length

-- Helper notation for creating Fin literals
notation:max "#" a:max  => (Fin.mk a (by decide))

example : [10, true, 20.1].nth #0 = (10:Nat) := rfl
example : [10, true, 20.1].nth #1 = true     := rfl
example : [10, true, 20.1].nth #2 = (20.1:Float) := rfl

#eval [10, true, 20.1].nth #0
#eval [10, true, 20.1].nth #1
#eval [10, true, 20.1].nth #2

def HListPatternMatch (l : HList [Nat, String]) :=
  match l with
  | [1, "2"] => true
  | [2, "1"] => true
  | _ => false

#eval HListPatternMatch [1, "2"]
#eval HListPatternMatch [2, "1"]
#eval HListPatternMatch [3, "1"]

example : HListPatternMatch [1, "2"] := rfl
example : HListPatternMatch [2, "1"] := rfl
example : !HListPatternMatch [3, "1"] := rfl

example : HListPatternMatch (1 :: "2" :: []) := rfl

instance : Repr (HList []) where
  reprPrec xs _ := "[]"

instance [Repr α] (αs : List Type) [Repr (HList αs)] : Repr (HList (α :: αs)) where
  reprPrec xs _ :=
    match xs with
    | x :: xs => repr x ++ " :: " ++ repr xs

def xs : HList [Nat, String, Bool] := [0, "hello", true]

#eval xs
-- 0 :: "hello" :: true :: []

def ys : HList (([Nat] : List Type) ++ ([String, Bool] : List Type)) := 0 :: "hello" :: true :: []

#eval ys

example : xs = ys :=
  rfl