import for_mathlib.Profinite.extend
import for_mathlib.Profinite.product

import data.fintype.card
import category_theory.limits.functor_category
import category_theory.limits.shapes.binary_products
import category_theory.functor.currying

import facts
import hacks_and_tricks.type_pow

import Lbar.basic
import pseudo_normed_group.profinitely_filtered

/-!
# $\overline{\mathcal{M}}_{r'}(S)_{≤ c}$

In this file we put a profinite topology on the subspace
`Lbar_le r' S c` of `Lbar r' S` consisting of power series
`F_s = ∑ a_{n,s}T^n ∈ Tℤ⟦T⟧` such that `∑_{n,s} |a_{n,s}|r'^n ≤ c`.
-/

universe u

noncomputable theory
open_locale big_operators nnreal
open pseudo_normed_group category_theory category_theory.limits
local attribute [instance] type_pow

variables {r' : ℝ≥0} {S : Type u} [fintype S] {c c₁ c₂ c₃ : ℝ≥0}

/-- `Lbar_le r' S c` is the set of power series
`F_s = ∑ a_{n,s}T^n ∈ Tℤ[[T]]` such that `∑_{n,s} |a_{n,s}|r'^n ≤ c` -/
def Lbar_le (r' : ℝ≥0) (S : Type u) [fintype S] (c : ℝ≥0) :=
{ F : Lbar r' S // F ∈ filtration (Lbar r' S) c }

namespace Lbar_le

instance has_coe : has_coe (Lbar_le r' S c) (Lbar r' S) := ⟨subtype.val⟩

instance has_coe_to_fun : has_coe_to_fun (Lbar_le r' S c) (λ F, S → ℕ → ℤ) := ⟨λ F, F.1⟩

@[simp] lemma coe_coe_to_fun (F : Lbar_le r' S c) : ⇑(F : Lbar r' S) = F := rfl

@[simp] lemma coe_mk (x h) : ((⟨x, h⟩ : Lbar_le r' S c) : S → ℕ → ℤ) = x := rfl

@[simp] protected lemma coeff_zero (x : Lbar_le r' S c) (s : S) : x s 0 = 0 := x.1.coeff_zero' s

protected lemma summable (x : Lbar_le r' S c) (s : S) :
  summable (λ n, (↑(x s n).nat_abs * r'^n)) := x.1.summable' s

protected lemma mem_filtration (x : Lbar_le r' S c) :
  x.1 ∈ filtration (Lbar r' S) c := x.property

/-- The inclusion map `Lbar_le r' S c₁ → Lbar_le r' S c₂` for `c₁ ≤ c₂`. -/
protected def cast_le [hc : fact (c₁ ≤ c₂)] (x : Lbar_le r' S c₁) : Lbar_le r' S c₂ :=
⟨⟨x, x.coeff_zero, x.summable⟩, filtration_mono hc.out x.mem_filtration⟩

@[simp] lemma coe_cast_le [hc : fact (c₁ ≤ c₂)] (x : Lbar_le r' S c₁) :
  ((x.cast_le : Lbar_le r' S c₂) : Lbar r' S) = x :=
by { ext, refl }

@[simp] lemma cast_le_apply [hc : fact (c₁ ≤ c₂)] (x : Lbar_le r' S c₁) (s : S) (i : ℕ) :
  (x.cast_le : Lbar_le r' S c₂) s i = x s i :=
rfl

lemma injective_cast_le [fact (c₁ ≤ c₂)] :
  function.injective (Lbar_le.cast_le : Lbar_le r' S c₁ → Lbar_le r' S c₂) :=
λ x y h,
begin
  ext s n,
  change x.cast_le s n = y.cast_le s n,
  rw h,
end

@[ext] lemma ext (x y : Lbar_le r' S c) (h : (⇑x: S → ℕ → ℤ) = y) : x = y :=
by { ext:2, exact h }

instance : has_zero (Lbar_le r' S c) := ⟨⟨0, zero_mem_filtration _⟩⟩

instance : inhabited (Lbar_le r' S c) := ⟨0⟩

end Lbar_le

variables (c₃)

/-- The addition on `Lbar_le`.
This addition is not homogeneous, but has type
`(Lbar_le r' S c₁) → (Lbar_le r' S c₂) → (Lbar_le r' S c₃)`
for `c₁ + c₂ ≤ c₃`. -/
def Lbar_le.add [h : fact (c₁ + c₂ ≤ c₃)]
  (F : Lbar_le r' S c₁) (G : Lbar_le r' S c₂) :
  Lbar_le r' S c₃ :=
subtype.mk (F + G) $ filtration_mono h.out $ add_mem_filtration F.mem_filtration G.mem_filtration

/-- An uncurried version of addition on `Lbar_le`,
meaning that it takes only 1 input, coming from a product type. -/
def Lbar_le.add' [fact (c₁ + c₂ ≤ c₃)] :
  Lbar_le r' S c₁ × Lbar_le r' S c₂ → Lbar_le r' S c₃ :=
λ x, Lbar_le.add c₃ x.1 x.2

-- TODO: register this as an instance??
/-- The negation on `Lbar_le`. -/
def Lbar_le.neg (F : Lbar_le r' S c) : Lbar_le r' S c :=
subtype.mk (-F) $ neg_mem_filtration F.mem_filtration

namespace Lbar_le

/-- The truncation map from Lbar_le to `Lbar_bdd`. -/
@[simps] def truncate (M : ℕ) (F : Lbar_le r' S c) : Lbar_bdd r' ⟨S⟩ c M :=
{ to_fun := λ s n, F s n,
  coeff_zero' := by simp,
  sum_le' :=
  begin
    refine le_trans _ F.mem_filtration,
    apply finset.sum_le_sum,
    rintros (s : S) -,
    rw fin.sum_univ_eq_sum_range (λ i, (↑(F s i).nat_abs * r' ^i)) (M+1),
    exact sum_le_tsum _ (λ _ _, subtype.property (_ : ℝ≥0)) (F.summable s),
  end }

lemma truncate_surjective (M : ℕ) :
  function.surjective (truncate M : Lbar_le r' S c → Lbar_bdd r' ⟨S⟩ c M) :=
begin
  intro x,
  have aux : _ := _,
  let F : Lbar_le r' S c :=
  ⟨{ to_fun := λ s n, if h : n < M + 1 then x s ⟨n, h⟩ else 0,
     summable' := aux, .. }, _⟩,
  { use F, ext s i, simp only [truncate_to_fun], dsimp,
    rw dif_pos i.is_lt, simp only [fin.eta] },
  { intro s, rw dif_pos (nat.zero_lt_succ _), exact x.coeff_zero s },
  { apply le_trans _ x.sum_le,
    apply finset.sum_le_sum,
    rintro s -,
    rw [← sum_add_tsum_nat_add' (M + 1), tsum_eq_zero, add_zero],
    { rw ← fin.sum_univ_eq_sum_range,
      apply finset.sum_le_sum,
      rintro i -,
      simp only [dif_pos i.is_lt, fin.eta, Lbar.coe_mk] },
    { intro i,
      dsimp,
      rw [dif_neg, int.nat_abs_zero, nat.cast_zero, zero_mul],
      linarith },
    { dsimp, apply aux } },
  { intro s,
    apply @summable_of_ne_finset_zero _ _ _ _ _ (finset.range (M+1)),
    intros i hi,
    rw finset.mem_range at hi,
    simp only [hi, zero_mul, dif_neg, not_false_iff, nat.cast_zero, int.nat_abs_zero] }
end

/-- Injectivity of the map `Lbar_le` to the limit of the `Lbar_bdd`. -/
lemma eq_iff_truncate_eq (x y : Lbar_le r' S c)
  (cond : ∀ M, truncate M x = truncate M y) : x = y :=
begin
  ext s n,
  change (truncate n x).1 s ⟨n, by linarith⟩ = (truncate n y).1 s ⟨n,_⟩,
  rw cond,
end

lemma truncate_cast_le (M : ℕ) [hc : fact (c₁ ≤ c₂)] (x : Lbar_le r' S c₁) :
  truncate M (Lbar_le.cast_le x : Lbar_le r' S c₂) = Lbar_bdd.cast_le (truncate M x) :=
rfl

/-- Underlying function of the element of `Lbar_le r' S c` associated to a sequence of
  elements of the truncated Lbars. -/
def mk_seq (T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M) : S → ℕ → ℤ :=
λ s n, (T n).1 s ⟨n, lt_add_one n⟩

@[simp] lemma mk_seq_zero {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M} (s : S) : mk_seq T s 0 = 0 :=
(T 0).coeff_zero s

lemma mk_seq_eq_of_compat {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M}
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M)
  {s : S} {n : ℕ} {M : ℕ} (hnM : n < M + 1) :
  mk_seq T s n = (T M).1 s ⟨n, hnM⟩ :=
begin
  have hnM : n ≤ M := nat.lt_succ_iff.mp hnM,
  unfold mk_seq,
  rw ← compat n M hnM,
  apply Lbar_bdd.transition_eq,
end

lemma mk_seq_sum_range_eq (T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M)
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M) (s : S) (n) :
  ∑ i in finset.range (n+1), (↑(mk_seq T s i).nat_abs * r'^i) =
  ∑ i : fin (n+1), (↑((T n).1 s i).nat_abs * r'^(i:ℕ)) :=
begin
  rw ← fin.sum_univ_eq_sum_range,
  congr',
  ext ⟨i, hi⟩,
  congr',
  exact mk_seq_eq_of_compat compat _,
end

lemma mk_seq_summable {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M}
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M) (s : S) :
  summable (λ (n : ℕ), (↑(mk_seq T s n).nat_abs * r' ^ n)) :=
begin
  apply @nnreal.summable_of_sum_range_le _ c,
  rintro (_|n),
  { simp only [finset.sum_empty, finset.range_zero, zero_le'] },
  { rw mk_seq_sum_range_eq T compat s n,
    refine le_trans _ (T n).sum_le,
    refine finset.single_le_sum (λ _ _, _) (finset.mem_univ s),
    apply zero_le' },
end

open filter

lemma mk_seq_tendsto {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M}
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M) :
  tendsto (λ (n : ℕ), ∑ (s : S), ∑  i in finset.range n, (↑(mk_seq T s i).nat_abs * r'^i))
  at_top (nhds $ ∑ (s : S), ∑' n, (↑(mk_seq T s n).nat_abs * r'^n)) :=
tendsto_finset_sum _ $ λ s _, has_sum.tendsto_sum_nat $ summable.has_sum $ mk_seq_summable compat s

lemma mk_seq_sum_le {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M}
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M) :
  (∑ s, ∑' (n : ℕ), (↑(mk_seq T s n).nat_abs * r' ^ n)) ≤ c :=
begin
  refine le_of_tendsto (mk_seq_tendsto compat) (eventually_of_forall _),
  rintro (_|n),
  { simp only [finset.sum_empty, finset.range_zero, finset.sum_const_zero, zero_le'] },
  { convert (T n).sum_le,
    funext,
    rw mk_seq_sum_range_eq T compat s n,
    refl }
end

lemma truncate_mk_seq {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M}
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M) (M : ℕ) :
  truncate M ⟨⟨mk_seq T, mk_seq_zero, mk_seq_summable compat⟩, mk_seq_sum_le compat⟩ = T M :=
begin
  ext s ⟨i, hi⟩,
  exact mk_seq_eq_of_compat compat _,
end

/-- `of_compat hT` is the limit of a compatible family `T M : Lbar_bdd r' ⟨S⟩ c M`.
This realizes `Lbar_le` as the profinite limit of the spaces `Lbar_bdd`,
see also `Lbar_le.eqv`. -/
def of_compat {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M}
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M) : Lbar_le r' S c :=
⟨⟨mk_seq T, mk_seq_zero, mk_seq_summable compat⟩, mk_seq_sum_le compat⟩

@[simp] lemma truncate_of_compat {T : Π (M : ℕ), Lbar_bdd r' ⟨S⟩ c M}
  (compat : ∀ (M N : ℕ) (h : M ≤ N), Lbar_bdd.transition r' h (T N) = T M) (M : ℕ) :
  truncate M (of_compat compat) = T M :=
begin
  ext s ⟨i, hi⟩,
  exact mk_seq_eq_of_compat compat _,
end

/-- The equivalence (as types) between `Lbar_le r' S c`
and the profinite limit of the spaces `Lbar_bdd r' ⟨S⟩ c M`. -/
def eqv : Lbar_le r' S c ≃ Lbar_bdd.limit r' ⟨S⟩ c :=
{ to_fun := λ F, ⟨λ N, truncate _ F, by { intros, refl }⟩,
  inv_fun := λ F, of_compat F.2,
  left_inv := λ x, by { ext, refl },
  right_inv := by { rintro ⟨x, hx⟩, simp only [truncate_of_compat], } }

section topological_structure

instance : topological_space (Lbar_le r' S c) := topological_space.induced eqv (by apply_instance)

lemma is_open_iff {U : set (Lbar_bdd.limit r' ⟨S⟩ c)} : is_open (eqv ⁻¹' U) ↔ is_open U :=
begin
  rw is_open_induced_iff,
  have := function.surjective.preimage_injective (equiv.surjective (eqv : Lbar_le r' S c ≃ _)),
  simp only [iff_self, this.eq_iff],
  simp only [exists_eq_right],
end

/-- The homeomorphism between `Lbar_le r' S c`
and the profinite limit of the spaces `Lbar_bdd r' ⟨S⟩ c M`.

This is `Lbar_le.eqv`, lifted to a homeomorphism by transporting
the topology from the profinite limit to `Lbar_le`. -/
def homeo : Lbar_le r' S c ≃ₜ Lbar_bdd.limit r' ⟨S⟩ c :=
{ continuous_to_fun := begin
    simp only [equiv.to_fun_as_coe, continuous_def],
    intros U hU,
    rwa is_open_iff
  end,
  continuous_inv_fun := begin
    simp only [equiv.to_fun_as_coe, continuous_def],
    intros U hU,
    erw [← eqv.image_eq_preimage, ← is_open_iff],
    rwa eqv.preimage_image U,
  end,
  ..eqv }

lemma truncate_eq (M : ℕ) :
  (truncate M : Lbar_le r' S c → Lbar_bdd r' ⟨S⟩ c M) = (Lbar_bdd.proj M) ∘ homeo := rfl

instance : t2_space (Lbar_le r' S c) :=
⟨λ x y h, separated_by_continuous homeo.continuous (λ c, h $ homeo.injective c)⟩

instance [fact (0 < r')] : compact_space (Lbar_le r' S c) :=
begin
  constructor,
  rw homeo.embedding.is_compact_iff_is_compact_image,
  simp only [set.image_univ, homeomorph.range_coe],
  obtain ⟨h⟩ := (by apply_instance : compact_space (Lbar_bdd.limit r' ⟨S⟩ c)),
  exact h,
end

instance : totally_disconnected_space (Lbar_le r' S c) :=
{ is_totally_disconnected_univ :=
  begin
    rintros A - hA,
    suffices subsing : (homeo '' A).subsingleton,
    { intros x hx y hy, apply_rules [homeo.injective, subsing, set.mem_image_of_mem] },
    obtain ⟨h⟩ := (by apply_instance : totally_disconnected_space (Lbar_bdd.limit r' ⟨S⟩ c)),
    exact h _ (by tauto) (is_preconnected.image hA _ homeo.continuous.continuous_on)
  end }

lemma continuous_iff {α : Type*} [topological_space α] (f : α → Lbar_le r' S c) :
  continuous f ↔ (∀ M, continuous ((truncate M) ∘ f)) :=
begin
  split,
  { intros hf M,
    rw [truncate_eq, function.comp.assoc],
    revert M,
    rw ← Lbar_bdd.continuous_iff,
    refine continuous.comp homeo.continuous hf },
  { intro h,
    suffices : continuous (homeo ∘ f), by rwa homeo.comp_continuous_iff at this,
    rw Lbar_bdd.continuous_iff,
    exact h }
end

lemma continuous_truncate {M} : continuous (@truncate r' S _ c M) :=
(continuous_iff id).mp continuous_id _

lemma continuous_add' :
  continuous (Lbar_le.add' (c₁ + c₂) : Lbar_le r' S c₁ × Lbar_le r' S c₂ → Lbar_le r' S (c₁+c₂)) :=
begin
  rw continuous_iff,
  intros M,
  have : truncate M ∘ (λ x : Lbar_le r' S c₁ × Lbar_le r' S c₂, Lbar_le.add _ x.1 x.2) =
    (λ x : (Lbar_le r' S c₁ × Lbar_le r' S c₂), Lbar_bdd.add (truncate M x.1) (truncate M x.2)) :=
    by {ext; refl},
  erw this,
  suffices : continuous (λ x : Lbar_bdd r' ⟨S⟩ c₁ M × Lbar_bdd r' ⟨S⟩ c₂ M, Lbar_bdd.add x.1 x.2),
  { have claim : (λ x : (Lbar_le r' S c₁ × Lbar_le r' S c₂),
      Lbar_bdd.add (truncate M x.1) (truncate M x.2)) =
      (λ x : Lbar_bdd r' ⟨S⟩ c₁ M × Lbar_bdd r' ⟨S⟩ c₂ M, Lbar_bdd.add x.1 x.2) ∘
      (λ x : Lbar_le r' S c₁ × Lbar_le r' S c₂, (truncate M x.1, truncate M x.2)), by {ext, refl},
    rw claim,
    refine continuous.comp this _,
    refine continuous.prod_map continuous_truncate continuous_truncate },
  exact continuous_of_discrete_topology,
end

lemma continuous_neg : continuous (Lbar_le.neg : Lbar_le r' S c → Lbar_le r' S c) :=
begin
  rw continuous_iff,
  intro M,
  change continuous (λ x : Lbar_le r' S c, Lbar_bdd.neg (truncate M x)),
  exact continuous.comp continuous_of_discrete_topology continuous_truncate,
end

end topological_structure

lemma continuous_cast_le (r' : ℝ≥0) (S : Type u) [fintype S] (c₁ c₂ : ℝ≥0) [hc : fact (c₁ ≤ c₂)] :
  continuous (@Lbar_le.cast_le r' S _ c₁ c₂ _) :=
begin
  rw continuous_iff,
  intro M,
  simp only [function.comp, truncate_cast_le],
  exact continuous_bot.comp continuous_truncate
end

/-! We now prove some scaffolding lemmas
in order to prove that the action of `T⁻¹` is continuous. -/

lemma continuous_of_normed_group_hom
  (f : (Lbar r' S) →+ (Lbar r' S))
  (g : Lbar_le r' S c₁ → Lbar_le r' S c₂)
  (h : ∀ x, ↑(g x) = f x)
  (H : ∀ M, ∃ N, ∀ (F : Lbar r' S),
    (∀ s i, i < N + 1 → F s i = 0) → (∀ s i, i < M + 1 → f F s i = 0)) :
  continuous g :=
begin
  rw continuous_iff,
  intros M,
  rcases H M with ⟨N, hN⟩,
  let φ : Lbar_bdd r' ⟨S⟩ c₁ N → Lbar_le r' S c₁ :=
    classical.some (truncate_surjective N).has_right_inverse,
  have hφ : function.right_inverse φ (truncate N) :=
    classical.some_spec (truncate_surjective N).has_right_inverse,
  suffices : truncate M ∘ g = truncate M ∘ g ∘ φ ∘ truncate N,
  { rw [this, ← function.comp.assoc, ← function.comp.assoc],
    apply continuous_bot.comp continuous_truncate },
  ext1 x,
  suffices : ∀ s i, i < M + 1 → (g x) s i = (g (φ (truncate N x))) s i,
  { ext s i, dsimp [function.comp], apply this, exact i.property },
  intros s i hi,
  rw [← coe_coe_to_fun, h, ← coe_coe_to_fun, h, ← sub_eq_zero],
  show ((f x) - f (φ (truncate N x))) s i = 0,
  rw [← f.map_sub],
  apply hN _ _ _ _ hi,
  clear hi i s, intros s i hi,
  simp only [Lbar.coe_sub, pi.sub_apply, sub_eq_zero],
  suffices : ∀ s i, (truncate N x) s i = truncate N (φ (truncate N x)) s i,
  { exact this s ⟨i, hi⟩ },
  intros s i, congr' 1,
  rw hφ (truncate N x)
end

/-- Construct a map between `Lbar_le r' S c₁` and `Lbar_le r' S c₂`
from a bounded group homomorphism `Lbar r' S → Lbar r' S`.

If `f` satisfies a suitable criterion,
then the constructed map is continuous for the profinite topology;
see `continuous_of_normed_group_hom`. -/
def hom_of_normed_group_hom {C : ℝ≥0} (c₁ c₂ : ℝ≥0) [hc : fact (C * c₁ ≤ c₂)]
  (f : Lbar r' S →+ Lbar r' S) (h : f ∈ filtration (Lbar r' S →+ Lbar r' S) C)
  (F : Lbar_le r' S c₁) :
  Lbar_le r' S c₂ :=
⟨{ to_fun := λ s i, f F s i,
  coeff_zero' := Lbar.coeff_zero _,
  summable' := Lbar.summable _ },
  filtration_mono hc.out (h F.mem_filtration)⟩

lemma continuous_hom_of_normed_group_hom {C : ℝ≥0} (c₁ c₂ : ℝ≥0)
  [hc : fact (C * c₁ ≤ c₂)]
  (f : Lbar r' S →+ Lbar r' S) (h : f ∈ filtration (Lbar r' S →+ Lbar r' S) C)
  (H : ∀ M, ∃ N, ∀ (F : Lbar r' S),
    (∀ s i, i < N + 1 → F s i = 0) → (∀ s i, i < M + 1 → f F s i = 0)) :
  continuous (hom_of_normed_group_hom c₁ c₂ f h) :=
continuous_of_normed_group_hom f _ (λ F, by { ext, refl }) H

@[simp] lemma coe_hom_of_normed_group_hom_apply {C : ℝ≥0} (c₁ c₂ : ℝ≥0)
  [hc : fact (C * c₁ ≤ c₂)]
  (f : Lbar r' S →+ Lbar r' S) (h : f ∈ filtration (Lbar r' S →+ Lbar r' S) C)
  (F : (Lbar_le r' S c₁)) (s : S) (i : ℕ) :
  (hom_of_normed_group_hom c₁ c₂ f h) F s i = f F s i := rfl

section Tinv

/-!
### The action of T⁻¹
-/

/-- The action of `T⁻¹` as map `Lbar_le r S c₁ → Lbar_le r S c₂`.

This action is induced by the action of `T⁻¹` on power series modulo constants: `ℤ⟦T⟧/ℤ`.
So `T⁻¹` sends `T^(n+1)` to `T^n`, but `T^0 = 0`. -/
def Tinv {r : ℝ≥0} {S : Type u} [fintype S] {c₁ c₂ : ℝ≥0} [fact (0 < r)] [fact (r⁻¹ * c₁ ≤ c₂)] :
  Lbar_le r S c₁ → Lbar_le r S c₂ :=
hom_of_normed_group_hom c₁ c₂ Lbar.Tinv Lbar.Tinv_mem_filtration

@[simp] lemma Tinv_apply {r : ℝ≥0} {S : Type u} [fintype S] {c₁ c₂ : ℝ≥0}
  [fact (0 < r)] [fact (r⁻¹ * c₁ ≤ c₂)] (F : Lbar_le r S c₁) (s : S) (i : ℕ) :
  (Tinv F : Lbar_le r S c₂) s i = Lbar.Tinv (F : Lbar r S) s i :=
rfl

lemma continuous_Tinv (r : ℝ≥0) (S : Type u) [fintype S] (c₁ c₂ : ℝ≥0)
  [fact (0 < r)] [fact (r⁻¹ * c₁ ≤ c₂)] :
  continuous (@Tinv r S _ c₁ c₂ _ _) :=
continuous_hom_of_normed_group_hom c₁ c₂ _ Lbar.Tinv_mem_filtration $
begin
  intros M,
  use M+1,
  rintro F hF s (_|i) hi,
  { simp only [Lbar.Tinv, add_monoid_hom.mk'_apply, Lbar.coe_mk, Lbar.Tinv_aux_zero] },
  { simp only [Lbar.Tinv, Lbar.Tinv_aux_succ, add_monoid_hom.mk'_apply, Lbar.coe_mk],
    apply hF,
    exact nat.succ_lt_succ hi },
end

end Tinv

/-

section map

/-- TODO -/
def map {S T : Fintype} (f : S ⟶ T) : Lbar_le r' S c → Lbar_le r' T c := λ F,
⟨(F : Lbar r' S).map f, Lbar.nnnorm_map_le_of_nnnorm_le _ _ F.2⟩

lemma map_truncate {S T : Fintype} (f : S ⟶ T) (F : Lbar_le r' S c) (M : ℕ) :
  ((F.truncate M).map f) = (F.map f).truncate M := rfl

lemma map_continuous {S T : Fintype} (f : S ⟶ T) : continuous
  (map f : Lbar_le r' S c → Lbar_le r' T c) :=
begin
  rw continuous_iff,
  intros M,
  have : truncate M ∘ (map f : Lbar_le r' S c → Lbar_le r' T c) =
    Lbar_bdd.map f ∘ truncate M, { ext, refl },
  rw this,
  refine continuous.comp _ continuous_truncate,
  continuity,
end

end map

variables (r' c)

/-- A version of `Lbar_le` which is functorial in `S`. -/
@[simps]
def Fintype_functor [fact (0 < r')] : Fintype.{u} ⥤ Profinite.{u} :=
{ obj := λ S, Profinite.of $ Lbar_le r' S c,
  map := λ S T f,
  { to_fun := map f,
    continuous_to_fun := map_continuous _ },
  map_id' := λ S, begin
    ext1,
    exact subtype.ext x.1.map_id,
  end,
  map_comp' := λ S T U f g, begin
    ext1,
    exact subtype.ext (x.1.map_comp f g),
  end }

variables (c₁ c₂)
/-- The functor sending `S` to the (categorical) product
  of `Lbar_le r' S c₁` and `Lbar_le r' S c₂`. -/
@[simps]
def Fintype_functor_prod [fact (0 < r')] : Fintype.{u} ⥤ Profinite.{u} :=
{ obj := λ S, (S,S),
  map := λ _ _ f, (f,f) } ⋙
    (Fintype_functor r' c₁).prod (Fintype_functor r' c₂) ⋙
    (uncurry.obj prod.functor)

/-- This is a functorial version of `add'`. -/
@[simps]
def Fintype_add_functor [fact (0 < r')] :
  Fintype_functor_prod.{u} r' c₁ c₂ ⟶ Fintype_functor.{u} r' (c₁ + c₂) :=
{ app := λ S, (Profinite.prod_iso _ _).hom ≫ ⟨add' _, continuous_add'⟩,
  naturality' := begin
    intros S T f,
    ext,
    dsimp only [functor.prod, Profinite.prod_iso, Fintype_functor_prod,
      uncurry, prod.functor, functor.comp_map],
    rw [category_theory.limits.prod.map_map, category.comp_id, category.id_comp],
    dsimp [map, Lbar.map, add', add, is_limit.cone_point_unique_up_to_iso,
      is_limit.unique_up_to_iso],
    rw finset.sum_add_distrib,
    -- annoying
    have useful : ∀ {A B C : Profinite} (f : A ⟶ B) (g : B ⟶ C) (a : A),
      (f ≫ g) a = g (f a) := λ _ _ _ _ _ _, rfl,
    congr,
    { have : binary_fan.fst (limit.cone (pair (Profinite.of (Lbar_le r' ↥T c₁))
        (Profinite.of (Lbar_le r' ↥T c₂)))) = category_theory.limits.prod.fst := rfl,
      rw [this, ← useful, category_theory.limits.prod.map_fst],
      refl },
    { have : binary_fan.snd (limit.cone (pair (Profinite.of (Lbar_le r' ↥T c₁))
        (Profinite.of (Lbar_le r' ↥T c₂)))) = category_theory.limits.prod.snd := rfl,
      rw [this, ← useful, category_theory.limits.prod.map_snd],
      refl },
  end}

/-- Negation on `Lbar_le` as a functor in `S`. -/
def Fintype_neg_functor [fact (0 < r')] : Fintype_functor.{u} r' c ⟶ Fintype_functor.{u} r' c :=
{ app := λ S, ⟨Lbar_le.neg, Lbar_le.continuous_neg⟩,
  naturality' := begin
    intros A B f,
    ext,
    dsimp [map, neg],
    simp,
  end }

variables {c₁ c₂}

open category_theory

/-- A bifunctor version of `Fintype_functor`, where `c` can vary. -/
@[simps]
def Fintype_bifunctor [fact (0 < r')] : ℝ≥0 ⥤ Fintype.{u} ⥤ Profinite.{u} :=
{ obj := λ c, Fintype_functor r' c,
  map := λ c₁ c₂ f,
  { app := λ S,
    { to_fun := @Lbar_le.cast_le r' S _ c₁ c₂ ⟨le_of_hom f⟩,
      continuous_to_fun := by apply continuous_cast_le } },
  map_id' := λ c, by { ext, refl },
  map_comp' := λ a b c f g, by { ext, refl } }

/-- The extension of `Fintype_functor` to `Profinite` obtained by taking limits. -/
@[simps]
def functor [fact (0 < r')] : Profinite.{u} ⥤ Profinite.{u} :=
Profinite.extend (Fintype_functor r' c)

variables (c₁ c₂)

/-- The profinite variant of `Fintype_functor_prod`. -/
@[simps]
def functor_prod [fact (0 < r')] : Profinite.{u} ⥤ Profinite.{u} :=
{ obj := λ S, (S,S), map := λ _ _ f, (f, f) } ⋙
  (functor r' c₁).prod (functor r' c₂) ⋙
  (uncurry.obj prod.functor)

/-- A cone over `(S.fintype_diagram ⋙ Fintype_functor_prod r' c₁ c₂)` used in the definition
  of `add_functor`. -/
def functor_prod_cone [fact (0 < r')] (S : Profinite) :
  cone (S.fintype_diagram ⋙ Fintype_functor_prod.{u} r' c₁ c₂) :=
{ X := (functor_prod r' c₁ c₂).obj S,
  π :=
  { app := λ I, category_theory.limits.prod.map (limit.π _ I) (limit.π _ I),
    naturality' := begin
      intros I J f,
      dsimp [Fintype_functor_prod],
      simp [← limit.w _ f],
    end } }

-- TODO: this proof is SLOW.
/-- The profinite variant of `Fintype_add_functor`. -/
def add_functor [fact (0 < r')] : functor_prod.{u} r' c₁ c₂ ⟶ functor.{u} r' (c₁ + c₂) :=
-- Why doesn't this work without the "by apply ..."?
{ app := λ S, by apply limit.lift _ (functor_prod_cone r' c₁ c₂ S) ≫
      category_theory.limits.lim.map (whisker_left _ (Fintype_add_functor _ _ _)),
  naturality' := begin
    intros S T f,
    erw [limits.limit.lift_map, limits.limit.lift_map],
    dsimp only [whisker_left, limits.cones.postcompose],
    apply limit.hom_ext,
    intros I,
    dsimp only [nat_trans.comp_app, functor, Profinite.extend, Profinite.change_cone],
    simp_rw [category.assoc, limits.limit.lift_π],
    change _ = _ ≫ limit.π _ _ ≫ _,
    simp_rw [← category.assoc, limits.limit.lift_π],
    dsimp only [nat_trans.comp_app, functor_prod_cone, functor_prod,
      functor.comp_map, uncurry, limits.prod.functor],
    simp only [limits.prod.map_map, category.id_comp, category.comp_id, category.assoc],
    let e : Fintype.of (I.comap f.continuous) ⟶ Fintype.of I := discrete_quotient.map (le_refl _),
    erw ← (Fintype_add_functor r' c₁ c₂).naturality e,
    simp_rw ← category.assoc,
    dsimp only [Fintype_functor_prod, functor.comp_map, uncurry, limits.prod.functor,
      functor.prod, functor, Profinite.extend],
    simp only [limits.prod.map_map, category.id_comp, category.comp_id, limits.limit.lift_π],
    refl,
  end }

/-- The profinite functorial variant of negation on `Lbar_le`. -/
def neg_functor [fact (0 < r')] : functor.{u} r' c ⟶ functor.{u} r' c :=
{ app := λ X, limits.lim.map $ whisker_left _ $ Fintype_neg_functor _ _,
  naturality' := begin
    intros A B f,
    apply limit.hom_ext,
    intros S,
    dsimp,
    simp,
  end }

variables {c₁ c₂}

/-- A bifunctor version of `functor`, where `c` can vary. -/
@[simps]
def bifunctor [fact (0 < r')] : ℝ≥0 ⥤ Profinite.{u} ⥤ Profinite.{u} :=
{ obj := λ c, functor r' c,
  map := λ a b f, Profinite.extend_nat_trans $ (Fintype_bifunctor r').map f,
  map_id' := begin
    intros c,
    rw (Fintype_bifunctor r').map_id,
    exact Profinite.extend_nat_trans_id _,
  end,
  map_comp' := begin
    intros a b c α β,
    rw (Fintype_bifunctor r').map_comp,
    exact Profinite.extend_nat_trans_comp _ _,
  end }

/-- `Lbar_le.functor r' c` is indeed an extension of `Lbar_le.Fintype_functor r' c`. -/
@[simps]
def functor_extends [fact (0 < r')] :
  Fintype.to_Profinite ⋙ functor.{u} r' c ≅ Fintype_functor.{u} r' c :=
Profinite.extend_extends _ .

variables {r' c}

-/

end Lbar_le

instance [fact (0 < r')] : profinitely_filtered_pseudo_normed_group (Lbar r' S) :=
{ topology := λ c, show topological_space (Lbar_le r' S c), by apply_instance,
  t2 := λ c, show t2_space (Lbar_le r' S c), by apply_instance,
  td := λ c, show totally_disconnected_space (Lbar_le r' S c), by apply_instance,
  compact := λ c, show compact_space (Lbar_le r' S c), by apply_instance,
  continuous_add' := λ c₁ c₂, Lbar_le.continuous_add',
  continuous_neg' := λ c, Lbar_le.continuous_neg,
  continuous_cast_le := λ c₁ c₂,
  begin
    introI h,
    rw show pseudo_normed_group.cast_le = (Lbar_le.cast_le : Lbar_le r' S c₁ → Lbar_le r' S c₂),
      by {ext, refl},
    exact Lbar_le.continuous_cast_le r' S c₁ c₂,
  end,
  .. Lbar.pseudo_normed_group }

/-

namespace Lbar

variable r'

/-- The diagram whose colimit yields `Lbar.profinite`. -/
def profinite_diagram [fact (0 < r')] : ℝ≥0 ⥤ Profinite.{u} ⥤ Type u :=
let E := (whiskering_right Profinite _ _).obj (forget Profinite) in
  ((whiskering_right _ _ _).obj E).obj (Lbar_le.bifunctor.{u} r')

/-- The functor `Lbar : Profinite ⥤ Type*`. -/
@[nolint check_univs] -- TODO remove this
def profinite [fact (0 < r')] : Profinite ⥤ Type* :=
(as_small.down ⋙ profinite_diagram r').flip ⋙ colim

attribute [nolint check_univs] profinite._proof_1

-- TODO: Move this to the condensed folder, once it's more stable!
/-- The representable presheaf associated to a profinite set. -/
def representable : Profinite.{u} ⥤ (as_small.{u+1} Profinite.{u})ᵒᵖ ⥤ Type (u+1) :=
let Y := @yoneda (as_small.{u+1} Profinite.{u}) _ in
((whiskering_right Profinite.{u} _ _).obj Y).obj as_small.up

/-- The diagram whose colimit yields `Lbar.precondensed`. -/
def precondensed_diagram [fact (0 < r')] :
  ℝ≥0 ⥤ Profinite.{u} ⥤ (as_small.{u+1} Profinite.{u})ᵒᵖ ⥤ Type (u+1) :=
let E := (whiskering_right Profinite _ _).obj representable in
((whiskering_right _ _ _).obj E).obj $ Lbar_le.bifunctor.{u} r'

/-- A functor associating to every `S : Profinite` the presheaf associated to the condensed set
`Lbar(S)`. -/
-- TODO: Prove that it is a condensed set!
def precondensed [fact (0 < r')] : Profinite.{u} ⥤ (as_small.{u+1} Profinite.{u})ᵒᵖ ⥤ Type (u+1) :=
(as_small.down.{_ _ (u+1)} ⋙ precondensed_diagram.{u} r').flip  ⋙ colim

end Lbar

-/

#lint-


namespace Lean4Axiomatic

/-! # Handedness -/

/--
Handedness: either left-handed or right-handed.

Intended to be used as a more meaniningful `Bool` type in contexts where it
applies. One example is in selecting the left- or right-hand side of an ordered
pair. Another is in specifying which side of a binary operator an algebraic
property acts on; a common one is the concept of a left inverse (`a⁻¹ * a ≃ 1`)
vs. a right inverse (`a * a⁻¹ ≃ 1`).
-/
inductive Hand where
| /-- Left hand.  -/ L
| /-- Right hand. -/ R

/--
Selects the left-hand or right-hand argument, according to the given `Hand`.

**Named parameters**
- `α`: The `Sort` of the items to select.
-/
abbrev Hand.pick {α : Sort u} : Hand → α → α → α
| L, x, _ => x
| R, _, y => y

end Lean4Axiomatic


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import Init.Notation

/- SizeOf -/

class SizeOf (α : Sort u) where
  sizeOf : α → Nat

export SizeOf (sizeOf)

/-
Declare sizeOf instances and theorems for types declared before SizeOf.
From now on, the inductive Compiler will automatically generate sizeOf instances and theorems.
-/

/- Every Type `α` has a default SizeOf instance that just returns 0 for every element of `α` -/
protected def default.sizeOf (α : Sort u) : α → Nat
  | a => 0

instance (priority := low) (α : Sort u) : SizeOf α where
  sizeOf := default.sizeOf α

@[simp] theorem sizeOf_default (n : α) : sizeOf n = 0 := rfl

instance : SizeOf Nat where
  sizeOf n := n

@[simp] theorem sizeOf_nat (n : Nat) : sizeOf n = n := rfl

deriving instance SizeOf for Prod
deriving instance SizeOf for PUnit
deriving instance SizeOf for Bool
deriving instance SizeOf for Option
deriving instance SizeOf for List
deriving instance SizeOf for Array
deriving instance SizeOf for Subtype
deriving instance SizeOf for Fin
deriving instance SizeOf for USize
deriving instance SizeOf for UInt8
deriving instance SizeOf for UInt16
deriving instance SizeOf for UInt32
deriving instance SizeOf for UInt64
deriving instance SizeOf for Char
deriving instance SizeOf for String
deriving instance SizeOf for Substring
deriving instance SizeOf for Except
deriving instance SizeOf for EStateM.Result

/- We manually define `Lean.Name` instance because we use
   an opaque function for computing the hashcode field. -/
protected noncomputable def Lean.Name.sizeOf : Name → Nat
  | anonymous => 1
  | str p s _ => 1 + Name.sizeOf p + sizeOf s
  | num p n _ => 1 + Name.sizeOf p + sizeOf n

noncomputable instance : SizeOf Lean.Name where
  sizeOf n := n.sizeOf

deriving instance SizeOf for Lean.Syntax


import .fol .abel

universe u

section weekdays
@[derive has_reflect]
inductive weekday : Type
| monday          : weekday
| another_day     : weekday → weekday

open weekday

meta def dump_weekday (f : weekday) : tactic unit :=
tactic.trace $ to_string (expr.to_raw_fmt (reflect f).to_expr)

-- run_cmd dump_weekday (another_day (another_day monday))
--(app (const weekday.another_day []) (app (const weekday.another_day []) (const weekday.monday [])))

inductive weekday' : Type
| monday          : weekday'
| another_day     : weekday' → weekday'

open weekday'
meta instance has_reflect_weekday' : has_reflect weekday'
| weekday'.monday                  := `(monday)
| (weekday'.another_day x)         := `(λ l, weekday'.another_day l).subst $
                                        by haveI := has_reflect_weekday'; exact (reflect x)

meta def dump_weekday' (f : weekday') : tactic unit :=
tactic.trace $ to_string (expr.to_raw_fmt (reflect f).to_expr)

-- run_cmd dump_weekday' (another_day (another_day monday))
-- (app (const weekday'.another_day []) (app (const weekday'.another_day []) (const weekday'.monday [])))
end weekdays
-- meta instance has_reflect_preterm {L : Language.{u}} : Π{n : ℕ}, has_reflect (preterm L n)
-- | 0 (var k) := `(@preterm.var L).subst (reflect k)

-- @[derive has_reflect]

open fol abel

section preterm_aux
inductive preterm_aux (L : Language.{u}) : Type u
| var     : ℕ → preterm_aux
| func    : ∀ k : ℕ, L.functions k → preterm_aux
| app     : preterm_aux → preterm_aux → preterm_aux

def to_aux {L : Language.{u}} : ∀ {l : ℕ},  preterm L l → preterm_aux L
| 0 (var n)      := preterm_aux.var _ n
| k (func f)     := preterm_aux.func _ f
| k (app t₁ t₂)  := preterm_aux.app (to_aux t₁) (to_aux t₂)

def L_abel_plus' (t₁ t₂ : preterm L_abel 0) : preterm L_abel 0 :=
@term_of_function L_abel 2 (abel_functions.plus : L_abel.functions 2) t₁ t₂
end preterm_aux

local infix ` +' `:100 := L_abel_plus'

local notation ` zero ` := (func abel_functions.zero : preterm L_abel 0)

section L_abel_term_biopsy

def sample1 : preterm L_abel 0 := (zero +' zero)

def sample2 : preterm L_abel 0 := zero

-- #reduce sample2

open expr
meta def sample2_expr : expr :=
mk_app (const `preterm.func list.nil) ([(const `L_abel list.nil), `(0), const `abel_functions.zero list.nil] : list expr)

end L_abel_term_biopsy

section simpler_biopsy

inductive my_inductive : Type
| a : my_inductive
| b : my_inductive
| f : my_inductive → my_inductive

open my_inductive
def sample3 : my_inductive := f a

open expr

meta def sample3_expr : expr :=
app (const `my_inductive.f list.nil) (const `my_inductive.a list.nil)

def sample3_again : my_inductive := by tactic.exact (sample3_expr)

example : sample3 = sample3_again := rfl

end simpler_biopsy

namespace tactic
namespace interactive
open interactive interactive.types expr

def my_test_term : preterm L_abel 0 := (zero +' zero)

end interactive
end tactic

section test
-- def my_term : preterm L_abel 0 := sorry

-- #check tactic.interactive.rcases

end test

section sample4

/-- Note: this is the same as `dfin` -/
inductive my_indexed_family : ℕ → Type u
| z {} : my_indexed_family 0
| s : ∀ {k}, my_indexed_family k → my_indexed_family (k+1)

-- meta example : ∀ {n}, has_reflect (my_indexed_family n)
-- | 0 z := `(z)

open my_indexed_family

def sample4 : my_indexed_family 1 := s z

-- #check tactic.eval_expr

end sample4

section sample4

inductive dfin'' : ℕ → Type
| fz {n} : dfin'' (n+1)
| fs {n} : dfin'' n → dfin'' (n+1)

inductive dfin' : ℕ → Type u
| gz {n} :  dfin' (n+1)
| gs {n} :  dfin' n → dfin' (n+1)

open dfin dfin'

meta instance dfin.reflect : ∀ {n}, has_reflect (dfin'' n)
| _ dfin''.fz := `(dfin''.fz)
| _ (dfin''.fs n) := `(dfin''.fs).subst (dfin.reflect n)

-- /- errors all over---why doesn't reflect like universe parameters? -/
-- meta instance dfin'.reflect : ∀ {n}, has_reflect (dfin' n)
-- | _ fz := `(fz)
-- | _ (fs n) := `(fs).subst (dfin'.reflect n)

end sample4

section reflect_preterm

/- Language with a single constant symbol -/
inductive L_pt_functions : ℕ → Type
| pt : L_pt_functions 0

def L_pt : Language.{0} := ⟨L_pt_functions, λ _, empty⟩

def pt_preterm : preterm L_pt 0 := preterm.func L_pt_functions.pt

meta def pt_preterm_reflected : expr :=
expr.mk_app (expr.const `preterm.func [level.zero]) [ (expr.const `L_pt list.nil), `(0), (expr.const `L_pt_functions.pt list.nil)]

set_option trace.app_builder true

-- meta def pt_preterm_reflected' : expr := by tactic.mk_app "preterm.func" [(expr.const `L_pt []), `(0), (expr.const `L_pt_functions.pt [])]

#check tactic.mk_app

meta def pt_preterm_reflected'' : tactic expr :=
tactic.to_expr ```(preterm.func L_pt_functions.pt : preterm L_pt 0)

def pt_preterm' : preterm L_pt 0 := by pt_preterm_reflected'' >>= tactic.exact

-- def pt_preterm' : preterm L_pt 0 := by tactic.exact pt_preterm_reflected

example : pt_preterm = pt_preterm' := rfl
  -- infer type failed, incorrect number of universe levels

-- want: example : pt_preterm = pt_preterm' := rfl

end reflect_preterm

namespace hewwo
section reflect_preterm2
def L_pt.pt' : L_pt.functions 0 := L_pt_functions.pt

#reduce (by apply_instance : reflected L_pt.pt')
-- `(L_pt.pt')

meta def pt_preterm_reflected : tactic expr :=
tactic.mk_app ``preterm.func [`(L_pt.pt')]

def pt_preterm' : preterm L_pt 0 := by pt_preterm_reflected >>= tactic.exact

#eval tactic.trace (@expr.to_raw_fmt tt `(L_pt.pt'))

#check reflect

end reflect_preterm2
end hewwo

section reflect_preterm3

inductive L_pt_func_functions : ℕ → Type
| pt  : L_pt_func_functions 0
| foo : L_pt_func_functions 1

open L_pt_func_functions

def L_pt_func : Language.{0} :=
⟨L_pt_func_functions, λ _, ulift empty⟩

-- def foo_pt_term : preterm L_pt_func 0 :=
-- preterm.app (preterm.func L_pt_func_functions.foo) (preterm.func L_pt_func_functions.pt)

-- def foo_pt_term_reflected : expr :=
-- begin
--   tactic.mk_app ``preterm.func [(by tactic.mk_app `preterm.func [`(L_pt_func_functions.foo)]), (by tactic.mk_app `preterm.func [`(L_pt_func_functions.pt)])]
-- end

-- def foo' : preterm L_pt_func 1 := preterm.func L_pt_func_functions.foo

-- #reduce (by apply_instance : reflected L_pt_func_functions.foo)

set_option trace.app_builder true

def my_foo : L_pt_func.functions 1 := L_pt_func_functions.foo

def my_pt : L_pt_func.functions 0 := L_pt_func_functions.pt

-- meta def foo_pt_term_reflected : tactic expr := tactic.mk_app ``preterm.func [`()]

meta def foo_pt_term_reflected' : tactic expr :=
do e₁ <- tactic.mk_app ``preterm.func [`(my_foo)],
   e₂ <- tactic.mk_app ``preterm.func [`(my_pt)],
   tactic.mk_app ``preterm.app [e₁, e₂]
-- #print foo_pt_term_reflected'

-- meta def bar : tactic expr :=
--   tactic.mk_app ``preterm.func [`(foo_mask)]

set_option trace.app_builder true

def foo_pt_term_reflected : preterm L_pt_func 0 := by (foo_pt_term_reflected' >>= tactic.exact)

-- #reduce foo_pt_term_reflected

end reflect_preterm3


structure A where
  x : Nat
  w : Nat

structure B extends A where
  y : Nat

structure C extends B where
  z : Nat

def f1 (c : C) (a : A) : C :=
  { c with toA := a, x := 0 }  -- Error, `toA` and `x` are both updates to field `x`

def f2 (c : C) (a : A) : C :=
  { c with toA := a }

def f3 (c : C) (a : A) : C :=
  { a, c with x := 0 }

theorem ex1 (a : A) (c : C) : (f3 c a).x = 0 :=
  rfl

theorem ex2 (a : A) (c : C) : (f3 c a).w = a.w :=
  rfl

def f4 (c : C) (a : A) : C :=
  { c, a with x := 0 } -- TODO: generate error that `a` was not used?

theorem ex3 (a : A) (c : C) : (f4 c a).w = c.w :=
  rfl

theorem ex4 (a : A) (c : C) : (f4 c a).x = 0 :=
  rfl

def f5 (c : C) (a : A) :=
  { c, a with x := 0 } -- Error


import QL.FOL.deduction

universes u v
open_locale logic_symbol

namespace fol
open logic subformula
variables (L : language.{u})

structure Structure (L : language.{u}) :=
(dom : Type u)
(fn : ∀ {n}, L.fn n → (fin n → dom) → dom)
(pr : ∀ {n}, L.pr n → (fin n → dom) → Prop)

instance Structure_coe {L : language} : has_coe_to_sort (Structure L) (Type*) := ⟨Structure.dom⟩

structure nonempty_Structure (L : language.{u}) extends Structure L :=
(dom_inhabited : inhabited dom)

instance nonempty_to_Structure_coe (L : language.{u}) : has_coe_t (nonempty_Structure L) (Structure L) := ⟨nonempty_Structure.to_Structure⟩

instance nonempty_Structure_dom_coe {L : language} : has_coe_to_sort (nonempty_Structure L) (Type*) :=
⟨λ S, ((S : Structure L) : Type*)⟩

instance (S : nonempty_Structure L) : inhabited S := S.dom_inhabited

structure finite_Structure (L : language.{u}) extends Structure L :=
(dom_finite : finite dom)

instance finite_Structure_coe (L : language.{u}) : has_coe_t (finite_Structure L) (Structure L) := ⟨finite_Structure.to_Structure⟩

variables {L} {μ : Type v} {μ₁ : Type*} {μ₂ : Type*}

open subterm subformula

namespace  subterm
variables (S : Structure L) {n : ℕ} (Φ : μ → S) (e : fin n → S)

@[simp] def val (Φ : μ → S) (e : fin n → S) : subterm L μ n → S
| (&x)           := Φ x
| (#x)           := e x
| (function f v) := S.fn f (λ i, (v i).val)

lemma val_rew (s : μ₁ → subterm L μ₂ n) (Φ : μ₂ → S) (e : fin n → S) (t : subterm L μ₁ n) :
  (rew s t).val S Φ e = t.val S (λ x, val S Φ e (s x)) e :=
by induction t; simp*

lemma val_map (f : μ₁ → μ₂) (Φ : μ₂ → S) (e : fin n → S) (t : subterm L μ₁ n) :
  (map f t).val S Φ e = t.val S (λ x, Φ (f x)) e :=
by simp[map, val_rew]

lemma val_subst (u : subterm L μ n) (t : subterm L μ (n + 1)) :
  (subst u t).val S Φ e = t.val S Φ (e <* u.val S Φ e) :=
by { induction t; simp*, case var : x { refine fin.last_cases _ _ x; simp } }

lemma val_lift (x : S) (t : subterm L μ n) :
  t.lift.val S Φ (x *> e) = t.val S Φ e :=
by induction t; simp*

section bounded_subterm
variables {m : ℕ} {Ψ : fin m → S}

lemma val_mlift (x : S) (t : bounded_subterm L m n) :
  t.mlift.val S (Ψ <* x) e = t.val S Ψ e :=
by simp[mlift, val_rew, val_map]

lemma val_push (x : S) (e : fin n → S) (t : bounded_subterm L m (n + 1)) :
  val S (Ψ <* x) e t.push = val S Ψ (e <* x) t :=
by { induction t; simp*, case var : u { refine fin.last_cases _ _ u; simp } }

lemma val_pull (x : S) (e : fin n → S) (t : bounded_subterm L (m + 1) n) :
  val S Ψ (e <* x) t.pull = val S (Ψ <* x) e t :=
by { induction t; simp*, case metavar : u { refine fin.last_cases _ _ u; simp } }

end bounded_subterm

end  subterm

namespace subformula
variables {μ μ₁ μ₂} (S : Structure L) {n : ℕ} {Φ : μ → S} {e : fin n → S}

@[simp] def subval' (Φ : μ → S) : ∀ {n} (e : fin n → S), subformula L μ n → Prop
| n _ verum          := true
| n e (relation p v) := S.pr p (subterm.val S Φ e ∘ v)
| n e (imply p q)    := p.subval' e → q.subval' e
| n e (neg p)        := ¬(p.subval' e)
| n e (fal p)        := ∀ x : S.dom, (p.subval' (x *> e))

@[irreducible] def subval (Φ : μ → S) (e : fin n → S) : subformula L μ n →ₗ Prop :=
{ to_fun := subval' S Φ e,
  map_neg' := λ _, by refl,
  map_imply' := λ _ _, by refl,
  map_and' := λ p q, by unfold has_inf.inf; simp[and]; refl,
  map_or' := λ p q, by unfold has_sup.sup; simp[or, ←or_iff_not_imp_left]; refl,
  map_top' := by refl,
  map_bot' := by simp[bot_def]; unfold has_top.top has_negation.neg; simp }

@[reducible] def val (Φ : μ → S) : formula L μ →ₗ Prop := subformula.subval S Φ fin.nil

@[simp] lemma subval_relation {p} {r : L.pr p} {v} :
  subval S Φ e (relation r v) ↔ S.pr r (λ i, subterm.val S Φ e (v i)) :=  by simp[subval]; refl

@[simp] lemma subval_fal {p : subformula L μ (n + 1)} :
  subval S Φ e (∀'p) ↔ ∀ x : S, subval S Φ (x *> e) p := by simp[subval]; refl

@[simp] lemma subval_ex {p : subformula L μ (n + 1)} :
  subval S Φ e (∃'p) ↔ ∃ x : S, subval S Φ (x *> e) p := by simp[ex_def]

lemma subval_rew {Φ : μ₂ → S} {n} {e : fin n → S} {s : μ₁ → subterm L μ₂ n} {p : subformula L μ₁ n} :
  subval S Φ e (rew s p) ↔ subval S (λ x, subterm.val S Φ e (s x)) e p :=
by induction p using fol.subformula.ind_on; intros; simp[*, subterm.val_rew, subterm.val_lift]

lemma subval_map {Φ : μ₂ → S} {n} {e : fin n → S} {f : μ₁ → μ₂} {p : subformula L μ₁ n} :
  subval S Φ e (map f p) ↔ subval S (λ x, Φ (f x)) e p :=
by simp[map, subval_rew]

@[simp] lemma subval_subst {n} {p : subformula L μ (n + 1)} : ∀ {e : fin n → S} {t : subterm L μ n},
  subval S Φ e (subst t p) ↔ subval S Φ (e <* subterm.val S Φ e t) p :=
by apply ind_succ_on p; intros; simp[*, subterm.val_subst, subterm.val_lift, fin.left_right_concat_assoc]

section bounded_subformula
variables {m : ℕ} {Ψ : fin m → S}

lemma subval_mlift {x} {p : bounded_subformula L m n} :
  subval S (Ψ <* x) e p.mlift = subval S Ψ e p := by simp[mlift, (∘), subval_map]

lemma subval_push {x} {n} {p : bounded_subformula L m (n + 1)} : ∀ {e : fin n → S},
  subval S (Ψ <* x) e p.push ↔ subval S Ψ (e <* x) p :=
by apply ind_succ_on p; intros; simp[*, subterm.val_push, fin.left_right_concat_assoc]

lemma subval_pull {x} {n} {p : bounded_subformula L (m + 1) n} : ∀ {e : fin n → S},
  subval S Ψ (e <* x) p.pull ↔ subval S (Ψ <* x) e p :=
by induction p using fol.subformula.ind_on generalizing Ψ; intros; simp[*, subterm.val_pull, fin.left_right_concat_assoc]

lemma subval_dummy {x} : ∀ {n} {e : fin n → S} {p : bounded_subformula L m n},
  subval S Ψ (e <* x) p.dummy ↔ subval S Ψ e p :=
by simp[dummy, subval_pull, subval_mlift]

end bounded_subformula

end subformula

namespace nonempty_Structure
variables (M : nonempty_Structure L)

lemma coe_def : (M : Structure L) = M.to_Structure := rfl

@[simp] lemma fn_coe : @Structure.fn L (M : Structure L) = @Structure.fn L M.to_Structure := rfl

@[simp] lemma pr_coe : @Structure.pr L (M : Structure L) = @Structure.pr L M.to_Structure := rfl

instance : inhabited (nonempty_Structure L) :=
⟨{ dom := punit,
   fn := λ k f v, punit.star,
   pr := λ k r v, false,
   dom_inhabited := punit.inhabited }⟩

end nonempty_Structure

namespace Structure

@[ext] lemma ext (S₁ S₂ : Structure L)
  (hdom : @dom L S₁ = @dom L S₂)
  (hfn : ∀ {k} (f : L.fn k), @fn L S₁ k f == @fn L S₂ k f)
  (hpr : ∀ {k} (r : L.pr k), @pr L S₁ k r == @pr L S₂ k r) : S₁ = S₂ :=
begin
  rcases S₁, rcases S₂, simp at hdom ⊢ hfn hpr, refine ⟨hdom, _, _⟩,
  { ext; simp, rintros k k rfl, ext; simp, rintros f f rfl, exact hfn f },
  { ext; simp, rintros k k rfl, ext; simp, rintros r r rfl, exact hpr r }
end

lemma eta (S : Structure L) : ({dom := S.dom, fn := @fn L S, pr := @pr L S} : Structure L) = S :=
by ext; simp

class Structure.proper_equal [L.has_equal] (S : Structure L)
(val_eq : ∀ {n : ℕ} {t u : subterm L μ n} {Φ e}, subformula.subval S Φ e (t =' u) ↔ (t.val S Φ e = u.val S Φ e))

def nonempty (S : Structure L) [c : inhabited S] : nonempty_Structure L :=
{ dom_inhabited := c, ..S }

variables (S : Structure L) [inhabited S]

@[simp] lemma coe_nonempty : (S.nonempty : Type*) = S := rfl

@[simp] lemma to_Structure_nonempty : (S.nonempty : Structure L) = S := by simp[nonempty, nonempty_Structure.coe_def, eta]

instance : inhabited (Structure L) :=
⟨(default : nonempty_Structure L)⟩

end Structure

namespace subformula
variables (S : Structure L) {Φ : μ → S}

notation S` ⊧[`:80 e`] `p :50 := val S e p

variables {S} {p q : formula L μ}

@[simp] lemma models_relation {k} {r : L.pr k} {v} :
  S ⊧[Φ] relation r v ↔ S.pr r (λ i, subterm.val S Φ fin.nil (v i)) := by simp[val]

section bounded
variables {m : ℕ} {Ψ : fin m → S}

@[simp] lemma val_fal {p : bounded_subformula L m 1} :
  S ⊧[Ψ] ∀'p ↔ ∀ x, S ⊧[Ψ <* x] p.push :=
by simp[val, subval_push, fin.concat_zero]

@[simp] lemma val_ex {p : bounded_subformula L m 1} :
  S ⊧[Ψ] ∃'p ↔ ∃ x, S ⊧[Ψ <* x] p.push :=
by simp[val, subval_push, fin.concat_zero]

@[simp] lemma val_subst {p : bounded_subformula L m 1} {t : bounded_subterm L m 0} :
  S ⊧[Ψ] subst t p ↔ S ⊧[Ψ <* subterm.val S Ψ fin.nil t] p.push :=
by simp[val, subval_subst, subval_push]

@[simp] lemma val_mlift {x : S} {p : bounded_subformula L m 0} : S ⊧[Ψ <* x] p.mlift ↔ S ⊧[Ψ] p :=
by simp[val, subval_mlift]

end bounded

end subformula

def models (S : Structure L) (p : formula L μ) : Prop := ∀ e, S ⊧[e] p

instance : semantics (formula L μ) (Structure L) := ⟨models⟩

instance : semantics (formula L μ) (nonempty_Structure L) := ⟨λ S p, (S : Structure L) ⊧ p⟩

namespace Structure

variables {S : Structure L} {σ τ : sentence L}

lemma models_def {p : formula L μ} : S ⊧ p ↔ (∀ e, S ⊧[e] p) := by refl

lemma sentence_models_def :
  S ⊧ σ ↔ S ⊧[fin.nil] σ := by simp[models_def, fin.nil]

@[simp] lemma formula_verum : S ⊧ (⊤ : formula L μ) := by simp[models_def]

@[simp] lemma sentence_falsum : ¬S ⊧ (⊥ : sentence L) := by simp[models_def]

@[simp] lemma sentence_relation {k} (r : L.pr k) (v : fin k → bounded_subterm L 0 0) :
  S ⊧ (relation r v) ↔ S.pr r (subterm.val S fin.nil fin.nil ∘ v) := by simp[sentence_models_def]

@[simp] lemma sentence_imply : S ⊧ σ ⟶ τ ↔ (S ⊧ σ → S ⊧ τ) := by simp[sentence_models_def]

@[simp] lemma sentence_neg : S ⊧ ∼σ ↔ ¬S ⊧ σ := by simp[sentence_models_def]

@[simp] lemma sentence_and : S ⊧ σ ⊓ τ ↔ S ⊧ σ ∧ S ⊧ τ := by simp[sentence_models_def]

@[simp] lemma sentence_or : S ⊧ σ ⊔ τ ↔ S ⊧ σ ∨ S ⊧ τ := by simp[sentence_models_def]

@[simp] lemma sentence_equiv : S ⊧ σ ⟷ τ ↔ (S ⊧ σ ↔ S ⊧ τ) := by simp[sentence_models_def]

instance : semantics.nontrivial (sentence L) (Structure L) :=
⟨by simp[models_def], by simp[models_def]⟩

abbreviation valid (p : formula L μ) : Prop := semantics.valid (Structure L) p

abbreviation satisfiable (p : formula L μ) : Prop := semantics.satisfiable (Structure L) p

lemma valid_def (p : formula L μ) : valid p ↔ ∀ S : Structure L, S ⊧ p := by refl

lemma satisfiable_def (p : formula L μ) : satisfiable p ↔ ∃ S : Structure L, S ⊧ p := by refl

abbreviation Satisfiable (T : preTheory L μ) : Prop := semantics.Satisfiable (Structure L) T

lemma Satisfiable_def (T : preTheory L μ) : Satisfiable T ↔ ∃ S: Structure L, S ⊧ T := by refl

@[simp] lemma sentence_not_valid_iff_satisfiable (σ : sentence L) : ¬valid σ ↔ satisfiable (∼σ) :=
by simp[valid_def, satisfiable_def]

@[simp] lemma models_mlift [inhabited S] {m} {p : bounded_formula L m} : S ⊧ p.mlift ↔ S ⊧ p :=
by{ simp[models_def], split,
    { intros h e,
      have : S ⊧[e <* default] p.mlift, from h _,
      simpa using this },
    { intros h e, rw ←fin.right_concat_eq e, simpa using h (e ∘ fin.cast_succ)} }

end Structure

namespace nonempty_Structure

variables {M : nonempty_Structure L} {σ τ : sentence L} {m : ℕ} {T : bounded_preTheory L m}

lemma models_def {p : formula L μ} :
  M ⊧ p ↔ (∀ e, ↑M ⊧[e] p) := by refl

lemma sentence_models_def {σ : sentence L} :
  M ⊧ σ ↔ ↑M ⊧[fin.nil] σ := by simp[models_def, fin.nil]

@[simp] lemma formula_verum : M ⊧ (⊤ : formula L μ) := by simp[models_def]

@[simp] lemma formula_falsum : ¬M ⊧ (⊥ : formula L μ) := by simp[models_def]

@[simp] lemma sentence_relation {k} {r : L.pr k} {v : fin k → bounded_subterm L 0 0} :
  M ⊧ (relation r v) ↔ M.pr r (subterm.val M fin.nil fin.nil ∘ v) := by simp[sentence_models_def]

@[simp] lemma sentence_imply : M ⊧ σ ⟶ τ ↔ (M ⊧ σ → M ⊧ τ) := by simp[sentence_models_def]

@[simp] lemma sentence_neg : M ⊧ ∼σ ↔ ¬M ⊧ σ := by simp[sentence_models_def]

@[simp] lemma sentence_and : M ⊧ σ ⊓ τ ↔ M ⊧ σ ∧ M ⊧ τ := by simp[sentence_models_def]

@[simp] lemma sentence_or : M ⊧ σ ⊔ τ ↔ M ⊧ σ ∨ M ⊧ τ := by simp[sentence_models_def]

@[simp] lemma sentence_equiv : M ⊧ σ ⟷ τ ↔ (M ⊧ σ ↔ M ⊧ τ) := by simp[sentence_models_def]

instance : semantics.nontrivial (formula L μ) (nonempty_Structure L) :=
⟨by simp[models_def], by simp[models_def]⟩

abbreviation valid (p : formula L μ) : Prop := semantics.valid (nonempty_Structure L) p

abbreviation satisfiable (p : formula L μ) : Prop := semantics.satisfiable (nonempty_Structure L) p

lemma valid_def (p : formula L μ) : valid p ↔ ∀ M : nonempty_Structure L, M ⊧ p := by refl

lemma satisfiable_def (p : formula L μ) : satisfiable p ↔ ∃ M : nonempty_Structure L, M ⊧ p := by refl

abbreviation Satisfiable (T : preTheory L μ) : Prop := semantics.Satisfiable (nonempty_Structure L) T

lemma Satisfiable_def (T : preTheory L μ) : Satisfiable T ↔ ∃ M : nonempty_Structure L, M ⊧ T := by refl

@[simp] lemma sentence_not_valid_iff_satisfiable (σ : sentence L) : ¬valid σ ↔ satisfiable (∼σ) :=
by simp[valid_def, satisfiable_def]

lemma coe_models_iff (p : formula L μ) : (M : Structure L) ⊧ p ↔ M ⊧ p := by refl

@[simp] lemma models_mlift {m} {p : bounded_formula L m} : M ⊧ p.mlift ↔ M ⊧ p :=
by simp[←coe_models_iff]

lemma coe_models_Theory_iff (T : preTheory L μ) : (M : Structure L) ⊧ T ↔ M ⊧ T := by refl

end nonempty_Structure

namespace Structure
open bounded_preTheory
variables {S : Structure L} {σ τ : sentence L} {m : ℕ} {T : bounded_preTheory L m}

lemma nonempty_models_iff [inhabited S] (p : formula L μ) : S.nonempty ⊧ p ↔ S ⊧ p :=
by simp[←nonempty_Structure.coe_models_iff]

lemma nonempty_models_Theory_iff [inhabited S] (T : preTheory L μ) : S.nonempty ⊧ T ↔ S ⊧ T :=
by simp[←nonempty_Structure.coe_models_Theory_iff]

@[simp] lemma models_Theory_mlift [inhabited S] : S ⊧ T.mlift ↔ S ⊧ T :=
⟨by { intros h p hp,
      have : S ⊧ p.mlift, from @h p.mlift (by simpa using hp),
      exact models_mlift.mp this },
 by { intros h p hp,
      rcases mem_mlift_iff.mp hp with ⟨q, hq, rfl⟩,
      exact models_mlift.mpr (h hq) }⟩

def consequence : preTheory L μ → formula L μ → Prop := semantics.consequence (Structure L)

infix ` ⊧₀ ` :55 := consequence

lemma consequence_def {T : preTheory L μ} {p : formula L μ} :
  T ⊧₀ p ↔ (∀ S : Structure L, S ⊧ T → S ⊧ p) := by refl

end Structure

namespace nonempty_Structure
open bounded_preTheory
variables {M : nonempty_Structure L} {σ τ : sentence L} {m : ℕ} {T : bounded_preTheory L m}

@[simp] lemma models_Theory_mlift : M ⊧ T.mlift ↔ M ⊧ T :=
by simp[←coe_models_Theory_iff]

instance : has_double_turnstile (preTheory L μ) (formula L μ) := ⟨semantics.consequence (nonempty_Structure L)⟩

lemma consequence_def {T : preTheory L μ} {p : formula L μ} :
  T ⊧ p ↔ (∀ M : nonempty_Structure L, M ⊧ T → M ⊧ p) := by refl

end nonempty_Structure

variables {S : Structure L}
open subformula

theorem soundness {m} {T : bounded_preTheory L m} {p} : T ⊢ p → T ⊧₀ p :=
begin
  intros h,
  apply provable.rec_on h,
  { intros m T p b IH S hT Φ,
    simp[subformula.val], intros x,
    haveI : inhabited S, from ⟨x⟩,
    have : S ⊧ p, from @IH S (by simpa using hT),
    exact this (Φ <* x) },
  { intros m T p q b₁ b₂ m₁ m₂ S hT Φ,
    have h₁ : S ⊧[Φ] p → S ⊧[Φ] q, by simpa using m₁ hT Φ,
    have h₂ : S ⊧[Φ] p, from m₂ hT Φ,
    exact h₁ h₂ },
  { intros m T p hp S hS, exact hS hp },
  { intros m T S h Φ, simp },
  { intros m T p q S hS Φ, simp, intros h _, exact h },
  { intros m T p q r S hS Φ, simp,  intros h₁ h₂ h₃, exact h₁ h₃ (h₂ h₃) },
  { intros m T p q S hS Φ, simp, intros h₁, contrapose, exact h₁ },
  { intros m T p t S hS Φ, simp, intros h, exact h _ },
  { intros m T p q S hS Φ, simp, intros h₁ h₂ x, exact h₁ x h₂ }
end

instance {m} : logic.sound (bounded_formula L m) (Structure L) :=
⟨λ T p, soundness⟩

theorem nonempty_soundness {m} {T : bounded_preTheory L m} {p} : T ⊢ p → T ⊧ p :=
by intros h M hM; exact soundness h hM

instance {m} : logic.sound (bounded_formula L m) (nonempty_Structure L) :=
⟨λ T p, nonempty_soundness⟩

end fol


import .datatypes .additive .reconstruction_theorems tactic.norm_num
namespace polya

open expr tactic diseq_proof
--#check mk_nat_val_ne_proof use something like this below?
theorem fake_ne_zero_pf (q : ℚ) : q ≠ 0 := sorry
theorem fake_gt_zero_pf (q : ℚ) : q > 0 := sorry
theorem fake_lt_zero_pf (q : ℚ) : q < 0 := sorry
theorem fake_eq_zero_pf (q : ℚ) : q = 0 := sorry
theorem fake_ne_pf (q1 q2 : ℚ) : q1 ≠ q2 := sorry

private meta def solve_by_norm_num (e : expr) : tactic expr :=
do (_, pf) ← solve_aux e `[norm_num, tactic.done],
   return pf

meta def mk_ne_zero_pf (q : ℚ) : tactic expr :=
--do qe ← to_expr ``(%%(quote q) : ℚ),
--   to_expr ``(fake_ne_zero_pf (%%qe : ℚ))
--return `(fake_ne_zero_pf q)
solve_by_norm_num `(q ≠ 0)

-- proves that q > 0, q < 0, or q = 0
meta def mk_sign_pf (q : ℚ) : tactic expr :=
/-do qe ← to_expr `(%%(quote q) : ℚ),
   if q > 0 then to_expr `(fake_gt_zero_pf (%%qe : ℚ))
   else if q < 0 then to_expr `(fake_lt_zero_pf (%%qe : ℚ))
   else to_expr ``(fake_eq_zero_pf (%%qe : ℚ))-/
if q > 0 then --return `(fake_gt_zero_pf q)
  solve_by_norm_num `(q > 0)
else if q < 0 then --return `(fake_lt_zero_pf q)
  solve_by_norm_num `(q < 0)
else --return `(fake_eq_zero_pf q)
  solve_by_norm_num `(q = 0)

meta def mk_ne_pf (q1 q2 : ℚ) : tactic expr :=
/-do q1e ← to_expr ``(%%(quote q1) : ℚ),
   q2e ← to_expr ``(%%(quote q2) : ℚ),
   to_expr `(fake_ne_pf %%q1e %%q2e)-/
--return `(fake_ne_pf q1 q2)
solve_by_norm_num `(q1 ≠ q2)

meta def mk_int_sign_pf (z : ℤ) : tactic expr :=
if z > 0 then solve_by_norm_num `(z > 0) --return `(sorry : z > 0)
else if z < 0 then solve_by_norm_num `(z < 0)--return `(sorry : z < 0)
else solve_by_norm_num `(z = 0) --return `(sorry : z = 0)

-- proves z % 2 = 0 or z % 2 = 1
meta def mk_int_mod_pf (z : ℤ) : tactic expr :=
if z % 2 = 0 then return `(sorry : z % 2 = 0)
else return `(sorry : z % 2 = 1)

namespace diseq_proof
private meta def reconstruct_hyp (lhs rhs : expr) (c : ℚ) (pf : expr) : tactic expr :=
do mvc ← mk_mvar,
   pft ← infer_type pf,
   to_expr ``(%%lhs ≠ %%mvc * %%rhs) >>= unify pft,
   c' ← eval_expr rat mvc,
   if c = c' then return pf else fail "diseq_proof.reconstruct_hyp failed"

private meta def reconstruct_sym (rc : Π {lhs rhs : expr} {c : ℚ}, diseq_proof lhs rhs c → tactic expr)
        {lhs rhs c} (dp : diseq_proof lhs rhs c) : tactic expr :=
do symp ← rc dp,
   cnep ← mk_ne_zero_pf c,
   mk_mapp ``diseq_sym [none, none, none, cnep, symp] -- why doesn't mk_app work?

meta def reconstruct : Π {lhs rhs : expr} {c : ℚ}, diseq_proof lhs rhs c → tactic expr
| .(_) .(_) .(_) (hyp (lhs) (rhs) (c) e) := reconstruct_hyp lhs rhs c e
| .(_) .(_) .(_) (@sym lhs rhs c dp) := reconstruct_sym @reconstruct dp

end diseq_proof

namespace eq_proof

private meta def reconstruct_hyp (lhs rhs : expr) (c : ℚ) (pf : expr) : tactic expr :=
do mvc ← mk_mvar,
   pft ← infer_type pf,
   to_expr ``(%%lhs = %%mvc * %%rhs) >>= unify pft,
   c' ← eval_expr rat mvc,
   if c = c' then return pf else fail "eq_proof.reconstruct_hyp failed"

private meta def reconstruct_sym (rc : Π {lhs rhs : expr} {c : ℚ}, eq_proof lhs rhs c → tactic expr)
        {lhs rhs c} (dp : eq_proof lhs rhs c) : tactic expr :=
do symp ← rc dp,
   cnep ← mk_ne_zero_pf c, -- 5/1 ≠ 0
--   infer_type symp >>= trace,
--   infer_type cnep >>= trace,
   mk_mapp ``eq_sym [none, none, none, cnep, symp] -- why doesn't mk_app work?

variable iepr_fn : Π {lhs rhs i}, ineq_proof lhs rhs i → tactic expr

private meta def reconstruct_of_opp_ineqs_aux {lhs rhs i} (c : ℚ) (iep : ineq_proof lhs rhs i)
        (iepr : ineq_proof lhs rhs i.reverse) : tactic expr :=
do guard (bnot i.strict),
   pr1 ← iepr_fn iep, pr2 ← iepr_fn iepr,
   if i.to_comp.is_less then
     mk_mapp ``op_ineq [none, none, none, some pr1, some pr2]
   else
     mk_mapp ``op_ineq [none, none, none, some pr2, some pr1]

private theorem eq_sub_of_add_eq_facs {c1 c2 e1 e2 : ℚ} (hc1 : c1 ≠ 0) (h : c1 * e1 + c2 * e2 = 0) : e1 = -(c2/c1) * e2 :=
sorry

private meta def reconstruct_of_sum_form_proof (sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr) : expr → expr → ℚ → Π {sf},
       Π (sp : sum_form_proof ⟨sf, spec_comp.eq⟩), tactic expr | lhs rhs c sf sp :=
if lhs.lt rhs then -- flipped?
  reconstruct_of_sum_form_proof rhs lhs (1/c) sp
else do
  guard $ (sf.contains lhs) && (sf.contains rhs),
  let a := sf.get_coeff lhs in let b := sf.get_coeff rhs in do
  guard $ c = -(b/a),
  pf ← sfpr sp,
  nez ← mk_ne_zero_pf a,
  mk_app ``eq_sub_of_add_eq_facs [nez, pf]
--  fail "eq_proof.reconstruct_of_sum_proof not implemented yet"

meta def reconstruct_aux (sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr) : Π {lhs rhs : expr} {c : ℚ}, eq_proof lhs rhs c → tactic expr
| .(_) .(_) .(_) (hyp (lhs) (rhs) (c) e) := reconstruct_hyp lhs rhs c e
| .(_) .(_) .(_) (@sym lhs rhs c dp) := reconstruct_sym @reconstruct_aux dp
| .(_) .(_) .(_) (@of_opp_ineqs lhs rhs i c iep iepr) := reconstruct_of_opp_ineqs_aux @iepr_fn c iep iepr
| .(_) .(_) .(_) (@of_sum_form_proof lhs rhs c _ sp) := reconstruct_of_sum_form_proof @sfpr lhs rhs c sp
| .(_) .(_) .(_) (adhoc _ _ _ _ t) := t

end eq_proof

namespace ineq_proof

meta def guard_is_ineq (lhs rhs : expr) (iq : ineq) (pf : expr) : tactic expr :=
do mvc ← mk_mvar, pft ← infer_type pf,
match iq.to_comp with
| comp.lt := to_expr ``(%%lhs < %%mvc * %%rhs) >>= unify pft >> return mvc
| comp.le := to_expr ``(%%lhs ≤ %%mvc * %%rhs) >>= unify pft >> return mvc
| comp.gt := to_expr ``(%%lhs > %%mvc * %%rhs) >>= unify pft >> return mvc
| comp.ge := to_expr ``(%%lhs ≥ %%mvc * %%rhs) >>= unify pft >> return mvc
end

private meta def reconstruct_hyp (lhs rhs : expr) (iq : ineq) (pf : expr) : tactic expr :=
match iq.to_slope with
| slope.horiz  :=
  do tp ← infer_type pf, --trace "unifying tp in reconstruct_hyp1", trace tp,
     to_expr ``( %%(iq.to_comp.to_pexpr) %%rhs 0) >>= unify tp,
     return pf
| slope.some c :=
  do m ← guard_is_ineq lhs rhs iq pf,
     m' ← eval_expr rat m,
     if m' = c then return pf else fail "ineq_proof.reconstruct_hyp failed"
end

section
variable (rc : Π {lhs rhs : expr} {iq : ineq}, ineq_proof lhs rhs iq → tactic expr)
include rc

private meta def reconstruct_sym
        {lhs rhs iq} (ip : ineq_proof lhs rhs iq) : tactic expr :=
match iq.to_slope with
| slope.horiz  := do p ← pp (lhs, rhs), fail $ "reconstruct_sym failed on horiz slope: " ++ p.to_string
| slope.some m :=
  do --trace "in reconstruct sym", trace (lhs, rhs, m),
     symp ← rc ip, sgnp ← mk_sign_pf m, --trace "have proof of:", infer_type symp >>= trace,
--trace ("m", m), trace ("lhs, rhs", lhs, rhs), trace "sgnp", infer_type sgnp >>= trace, trace "symp", trace ip, infer_type symp >>= trace,
     --mk_mapp (name_of_c_and_comp m iq.to_comp) [none, none, none, some sgnp, some symp]
     mk_app (if m < 0 then ``sym_op_neg else ``sym_op_pos) [sgnp, symp]
end

-- x ≥ 2y and x ≠ 2y implies x > 2y
private meta def reconstruct_ineq_diseq {lhs rhs iq c} (ip : ineq_proof lhs rhs iq) (dp : diseq_proof lhs rhs c) : tactic expr :=
match iq.to_slope with
| slope.horiz := fail "reconstruct_ineq_diseq needs non-horiz slope"
| slope.some m :=
 if bnot (m=c) then
   fail "reconstruct_ineq_diseq found non-matching slopes"
 else if iq.strict then rc ip
 else do ipp ← rc ip, dpp ← dp.reconstruct,
 /-if iq.to_comp.is_less then
  mk_mapp ``ineq_diseq_le [none, none, none, some dpp, some ipp]
 else
  mk_mapp ``ineq_diseq_ge [none, none, none, some dpp, some ipp]-/
 mk_app ``ineq_diseq [dpp, ipp]
end

variable (rcs : Π {e gc}, sign_proof e gc → tactic expr)
include rcs

-- x ≤ 0y and x ≠ 0 implies x < 0y
private meta def reconstruct_ineq_sign_lhs {lhs rhs iq c} (ip : ineq_proof lhs rhs iq) (sp : sign_proof lhs c) : tactic expr :=
if iq.strict || bnot (c = gen_comp.ne) then fail "reconstruct_ineq_sign_lhs assumes a weak ineq and a diseq-0" else
match iq.to_slope with
| slope.horiz := fail "reconstruct_ineq_sign_lhs assumes a 0 slope"
| slope.some m :=
  if m = 0 then do
    ipp ← rc ip, spp ← rcs sp,
--    mk_app (if iq.to_comp.is_less then ``ineq_diseq_sign_lhs_le else ``ineq_diseq_sign_lhs_ge) [spp, ipp]
    mk_app ``ineq_diseq_sign_lhs [spp, ipp]
  else fail "reconstruct_ineq_sign_lhs assumes a 0 slope"
end

-- this might be wrong: should we produce proofs of y < 0?
private meta def reconstruct_ineq_sign_rhs {lhs rhs iq c} (ip : ineq_proof lhs rhs iq) (sp : sign_proof rhs c) : tactic expr :=
if iq.strict || bnot (c = gen_comp.ne) then fail "reconstruct_ineq_sign_rhs assumes a weak ineq and a diseq-0" else
match iq.to_slope with
| slope.horiz := do ipp ← rc ip, spp ← rcs sp,
--    mk_app (if iq.to_comp.is_less then ``ineq_diseq_sign_rhs_le else ``ineq_diseq_sign_rhs_ge) [spp, ipp]
    mk_app ``ineq_diseq_sign_rhs [spp, ipp]
| _ := fail "reconstruct_ineq_sign_rhs assumes a horizontal slope"
end

omit rc

-- x ≥ 0 implies x ≥ 0*y
private meta def reconstruct_zero_comp_of_sign {lhs c} (rhs : expr) (iq : ineq) (sp : sign_proof lhs c) : tactic expr :=
if bnot ((iq.to_comp.to_gen_comp = c) && (iq.is_zero_slope)) then fail $ "reconstruct_zero_comp_of_sign only produces comps with zero" ++ (to_fmt iq).to_string ++ (to_fmt iq.to_comp.to_gen_comp).to_string ++ (to_fmt c).to_string
--else do spp ← rcs sp, mk_app (zero_mul_name_of_comp iq.to_comp) [rhs, spp]
else do spp ← rcs sp, mk_mapp ``op_zero_mul [none, some rhs, none, none, some spp]

private meta def reconstruct_horiz_of_sign {rhs c} (lhs : expr) (iq : ineq) (sp : sign_proof rhs c) : tactic expr :=
if bnot ((iq.to_comp.to_gen_comp = c) && (iq.is_horiz)) then fail $ "reconstruct_horiz_of_sign failed"
else rcs sp

end

/-
private theorem eq_sub_of_add_eq_facs {c1 c2 e1 e2 : ℚ} (hc1 : c1 ≠ 0) (h : c1 * e1 + c2 * e2 = 0) : e1 = -(c2/c1) * e2 :=
sorry

private meta def reconstruct_of_sum_form_proof (sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr) : expr → expr → ℚ → Π {sf},
       Π (sp : sum_form_proof ⟨sf, spec_comp.eq⟩), tactic expr | lhs rhs c sf sp :=
if rhs.lt lhs then
  reconstruct_of_sum_form_proof rhs lhs (1/c) sp
else do
  guard $ (sf.contains lhs) && (sf.contains rhs),
  let a := sf.get_coeff lhs in let b := sf.get_coeff rhs in do
  guard $ c = -(b/a),
  pf ← sfpr sp,
  nez ← mk_ne_zero_pf a,
  mk_app ``eq_sub_of_add_eq_facs [nez, pf]
-/

private meta def reconstruct_of_sum_form_proof  (sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr) :
        expr → expr → ineq → Π {sfc}, sum_form_proof sfc → tactic expr | lhs rhs i sfc sp :=
if lhs.lt rhs then -- flipped?
  reconstruct_of_sum_form_proof rhs lhs i.reverse sp
else
 (match i.to_slope with
| slope.some m := do {
  guard $ (sfc.sf.contains lhs) && (sfc.sf.contains rhs),
  guard $ sfc.sf.keys.length = 2,
  let a := sfc.sf.get_coeff lhs in let b := sfc.sf.get_coeff rhs in do
  guard $ m = -(b/a),
  guard $ if a < 0 then sfc.c.to_comp = i.to_comp.reverse else sfc.c.to_comp = i.to_comp,
  rhs' ← to_expr ``(%%(↑(rat.reflect m) : expr) * %%rhs), -- better way to do this?
  tp ← i.to_comp.to_function lhs rhs',
  sgnp ← mk_sign_pf a,
  pf ← sfpr sp,
  --trace "have: ", infer_type pf >>= trace, trace ("lhs: ", lhs), trace ("rhs: ", rhs),
  let thnm := if a < 0 then ``op_of_sum_op_zero_neg else ``op_of_sum_op_zero_pos in
  mk_app thnm [pf, sgnp]}
  --to_expr ``(sorry : %%tp)
--  fail "ineq_proof.reconstruct_of_sum_proof not implemented yet"
| slope.horiz := fail "ineq_proof.reconstruct_of_sum_proof failed, cannot turn a sum into a horiz slope"
end)

meta def reconstruct_aux (rcs : Π {e gc}, sign_proof e gc → tactic expr) (sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr) :
     Π {lhs rhs : expr} {iq : ineq}, ineq_proof lhs rhs iq → tactic expr
| _ _ _ (hyp lhs rhs iq e) := reconstruct_hyp lhs rhs iq e
| _ _ _ (sym ip) := reconstruct_sym @reconstruct_aux ip
| _ _ _ (of_ineq_proof_and_diseq ip dp) := reconstruct_ineq_diseq @reconstruct_aux ip dp
| _ _ _ (of_ineq_proof_and_sign_lhs ip sp) := reconstruct_ineq_sign_lhs @reconstruct_aux @rcs ip sp
| _ _ _ (of_ineq_proof_and_sign_rhs ip sp) := reconstruct_ineq_sign_rhs @reconstruct_aux @rcs ip sp
| _ _ _ (zero_comp_of_sign_proof rhs iq sp) := reconstruct_zero_comp_of_sign @rcs rhs iq sp
| _ _ _ (horiz_of_sign_proof lhs iq sp) := reconstruct_horiz_of_sign @rcs lhs iq sp
| _ _ _ (of_sum_form_proof lhs rhs i sp) := reconstruct_of_sum_form_proof @sfpr lhs rhs i sp
| _ _ _ (adhoc _ _ _ _ t) := t

end ineq_proof

namespace sign_proof

private meta def reconstruct_hyp (e : expr) (gc : gen_comp) (pf : expr) : tactic expr :=
let pex := match gc with
| gen_comp.ge := ``(%%e ≥ 0)
| gen_comp.gt := ``(%%e > 0)
| gen_comp.le := ``(%%e ≤ 0)
| gen_comp.lt := ``(%%e < 0)
| gen_comp.eq := ``(%%e = 0)
| gen_comp.ne := ``(%%e ≠ 0)
end in do tp ← infer_type pf, to_expr pex >>= unify tp >> return pf

private meta def reconstruct_scaled_hyp (e : expr) (gc : gen_comp) (pf : expr) (q : ℚ) : tactic expr :=
do sp ← mk_sign_pf q,
   if q > 0 then
    mk_mapp ``op_zero_of_mul_op_zero_of_pos [none, none, none, none, pf, sp]
   else
    mk_mapp ``op_zero_of_mul_op_zero_of_neg [none, none, none, none, pf, sp]

section
parameter rc : Π {e c}, sign_proof e c → tactic expr
parameter sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr
private meta def rci := @ineq_proof.reconstruct_aux @rc @sfpr
private meta def rce := @eq_proof.reconstruct_aux @rci @sfpr

-- x ≤ 0*y to x ≤ 0
private meta def reconstruct_ineq_lhs (c : gen_comp) {lhs rhs iqp} (ip : ineq_proof lhs rhs iqp) : tactic expr :=
if bnot ((iqp.to_comp.to_gen_comp = c) && (iqp.is_zero_slope)) then fail "reconstruct_ineq_lhs must take a comparison with 0"
--else do ipp ← rci ip, mk_app (zero_mul'_name_of_comp iqp.to_comp) [ipp]
else do ipp ← rci ip, mk_app ``op_zero_mul' [ipp]

private meta def reconstruct_ineq_rhs (c : gen_comp) {lhs rhs iqp} (ip : ineq_proof lhs rhs iqp) : tactic expr :=
if bnot ((iqp.to_comp.to_gen_comp = c) && (iqp.is_horiz)) then fail "reconstruct_ineq_rhs must take a horiz comp"
else rci ip

private meta def reconstruct_eq_of_two_eqs_lhs {lhs rhs eqp1 eqp2} (ep1 : eq_proof lhs rhs eqp1) (ep2 : eq_proof lhs rhs eqp2) : tactic expr :=
if h : eqp1 = eqp2 then fail "reconstruct_eq_of_two_eqs lhs cannot infer anything from the same equality twice"
else do epp1 ← rce ep1, epp2 ← rce ep2, nep ← mk_ne_pf eqp1 eqp2,
        mk_app ``eq_zero_of_two_eqs_lhs [epp1, epp2, nep]

private meta def reconstruct_eq_of_two_eqs_rhs {lhs rhs eqp1 eqp2} (ep1 : eq_proof lhs rhs eqp1) (ep2 : eq_proof lhs rhs eqp2) : tactic expr :=
if h : eqp1 = eqp2 then fail "reconstruct_eq_of_two_eqs lhs cannot infer anything from the same equality twice"
else do epp1 ← rce ep1, epp2 ← rce ep2, nep ← mk_ne_pf eqp1 eqp2,
        mk_app ``eq_zero_of_two_eqs_rhs [epp1, epp2, nep]

private meta def reconstruct_diseq_of_diseq_zero {lhs rhs} (dp : diseq_proof lhs rhs 0) : tactic expr :=
do dpp ← dp.reconstruct,
   mk_app ``ne_zero_of_ne_mul_zero [dpp]

private meta def reconstruct_eq_of_eq_zero {lhs rhs} (ep : eq_proof lhs rhs 0) : tactic expr :=
do epp ← rce ep,
   mk_app ``eq_zero_of_eq_mul_zero [epp]

/-
private meta def reconstruct_ineqs (rct : contrad → tactic expr) {lhs rhs} (ii : ineq_info lhs rhs) (id : ineq_data lhs rhs) : tactic expr := do trace "ineqs!!",
match ii with
| ineq_info.no_comps := fail "reconstruct_ineqs cannot find a contradiction with no known comps"
| ineq_info.one_comp id2 := reconstruct_two_ineq_data rct id id2
| ineq_info.equal ed := reconstruct_eq_ineq ed id
| ineq_info.two_comps id1 id2 :=
   let sfid  := sum_form_comp_data.of_ineq_data id,
       sfid1 := sum_form_comp_data.of_ineq_data id1,
       sfid2 := sum_form_comp_data.of_ineq_data id2 in
   match find_contrad_in_sfcd_list [sfid, sfid1, sfid2] with
   | some ctr    := rct ctr
   | option.none := fail "reconstruct_ineqs failed to find contr"
   end
end
-/

private theorem {u} ge_of_not_lt {α : Type u} [linear_order α] {a b : α} (h : ¬ a < b) : (a ≥ b) := le_of_not_gt h

private theorem {u} gt_of_not_le {α : Type u} [linear_order α] {a b : α} (h : ¬ a ≤ b) : (a > b) := lt_of_not_ge h

private meta def neg_op_lemma_name : comp → name
| comp.lt := ``lt_of_not_ge
| comp.le := ``le_of_not_gt
| comp.ge := ``ge_of_not_lt
| comp.gt := ``gt_of_not_le

meta def reconstruct_ineq_of_eq_and_ineq_aux
-- (sfpr : Π {sf : sum_form_comp}, Π (sp : sum_form_proof sf), tactic.{0} (expr tt))
 {lhs rhs iq c} (c' : gen_comp) (ep : eq_proof lhs rhs c) (ip : ineq_proof lhs rhs iq) (pvt : expr) : tactic expr :=
do negt ← c'.to_comp.to_function pvt `(0 : ℚ),
   (_, notpf) ← solve_aux negt (do
     applyc $ neg_op_lemma_name c'.to_comp,
     hypv ← intro `h,
     let sfid := sum_form_comp_data.of_ineq_data ⟨_, ip⟩ in
     let sfed := sum_form_comp_data.of_eq_data ⟨_, ep⟩ in
     let sfsd := sum_form_comp_data.of_sign_data ⟨c'.negate, hyp pvt _ hypv⟩ in
     match find_contrad_sfcd_in_sfcd_list [sfid, sfed, sfsd] with
     | none := fail "reconstruct_ineq_of_eq_and_ineq failed to find proof"
     | some ⟨_, sfp, _⟩ := do ctrp ← sfpr sfp, fp ← mk_mapp ``lt_irrefl [none, none, none, ctrp], apply fp
--applyc ``lt_irrefl, trace "apply3", apply ctrp, trace "apply4"
     end),
   return notpf

--#check @reconstruct_ineq_of_eq_and_ineq_aux
-- these are the hard cases. Is this the right place to handle them?
private meta def reconstruct_ineq_of_eq_and_ineq_lhs {lhs rhs iq c} (c' : gen_comp) (ep : eq_proof lhs rhs c) (ip : ineq_proof lhs rhs iq) : tactic expr :=
reconstruct_ineq_of_eq_and_ineq_aux c' ep ip lhs
--fail "reconstruct_ineq_of_eq_and_ineq not implemented"

private meta def reconstruct_ineq_of_eq_and_ineq_rhs {lhs rhs iq c} (c' : gen_comp) (ep : eq_proof lhs rhs c) (ip : ineq_proof lhs rhs iq) : tactic expr :=
reconstruct_ineq_of_eq_and_ineq_aux c' ep ip rhs
/-do negt ← c'.to_comp.to_function rhs `(0 : ℚ),
   (_, notpf) ← solve_aux negt (do
     applyc $ neg_op_lemma_name c'.to_comp,
     hypv ← intro `h,
     let sfid := sum_form_comp_data.of_ineq_data ⟨_, ip⟩ in
     let sfed := sum_form_comp_data.of_eq_data ⟨_, ep⟩ in
     let sfsd := sum_form_comp_data.of_sign_data ⟨c', hyp rhs _ hypv⟩ in
     match find_contrad_sfcd_in_sfcd_list [sfid, sfed, sfsd] with
     | none := fail "reconstruct_ineq_of_eq_and_ineq_rhs failed to find proof"
     | some ⟨_, sfp, _⟩ := do ctrp ← sfpr sfp, applyc ``lt_irrefl, apply ctrp
     end),
   return notpf-/
--   fail "reconstruct_ineq_of_eq_and_ineq not implemented"

-- TODO
private meta def reconstruct_ineq_of_ineq_and_eq_zero_rhs {lhs rhs iq} (c : gen_comp) (ip : ineq_proof lhs rhs iq) (sp : sign_proof lhs gen_comp.eq) : tactic expr :=
fail "reconstruct_ineq_of_ineq_and_eq_zero not implemented"

private meta def reconstruct_diseq_of_strict_ineq {e c} (sp : sign_proof e c) : tactic expr :=
if c.is_strict then do
  spp ← rc sp,
  mk_app ``ne_of_strict_op [spp]
else fail "reconstruct_diseq_of_strict_ineq failed, comp is not strict"

end

-- TODO
private meta def reconstruct_of_sum_form_proof (sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr) (e : expr) (c : gen_comp) {sfc}
        (sp : sum_form_proof sfc) : tactic expr :=
do
   pf' ← sfpr sp,
   --trace "in sign_proof.reconstruct_of_sum_form_proof",
   --infer_type e >>= trace,
   --trace c,
   let coeff := sfc.sf.get_coeff e,
   if coeff = 0 then fail "sign_proof.reconstruct_of_sum_form_proof failed, zero coeff" else do
   coeff_sign_pr ← mk_sign_pf coeff,
--   if coeff < 0 then
     mk_mapp (if coeff < 0 then ``rev_op_zero_of_neg_mul_op_zero else ``op_zero_of_pos_mul_op_zero) [none, none, none, none, coeff_sign_pr, pf']
 --  else if coeff > 0 then
 --    mk_mapp ``op_zero_of_pos_mul_op_zero [none, none, none, none, coeff_sign_]
 --  fail "sign_proof.reconstruct_of_sum_form_proof failed, not implemented yet"

meta def reconstruct_eq_of_le_of_ge (rct : Π {e c}, sign_proof e c → tactic expr) {e} (lep : sign_proof e gen_comp.le) (gep : sign_proof e gen_comp.ge) : tactic expr :=
do lep' ← rct lep, gep' ← rct gep,
   mk_app ``le_antisymm' [lep', gep']

meta def reconstruct_aux (sfpr : Π {sf}, Π (sp : sum_form_proof sf), tactic expr) : Π {e c}, sign_proof e c → tactic expr
| .(_) .(_) (hyp e c pf) := reconstruct_hyp e c pf
| .(_) .(_) (scaled_hyp e c pf q) := reconstruct_scaled_hyp e c pf q
| .(_) .(_) (@ineq_lhs c _ _ _ ip) := reconstruct_ineq_lhs @reconstruct_aux @sfpr c ip
| .(_) .(_) (@ineq_rhs c _ _ _ ip) := reconstruct_ineq_rhs @reconstruct_aux @sfpr c ip
| .(_) .(_) (@eq_of_two_eqs_lhs _ _ _ _ ep1 ep2) := reconstruct_eq_of_two_eqs_lhs @reconstruct_aux @sfpr ep1 ep2
| .(_) .(_) (@eq_of_two_eqs_rhs _ _ _ _ ep1 ep2) := reconstruct_eq_of_two_eqs_rhs @reconstruct_aux @sfpr ep1 ep2
| .(_) .(_) (@diseq_of_diseq_zero _ _ dp) := reconstruct_diseq_of_diseq_zero dp
| .(_) .(_) (@eq_of_eq_zero _ _ ep) := reconstruct_eq_of_eq_zero @reconstruct_aux @sfpr ep
| .(_) .(_) (eq_of_le_of_ge lep gep) := reconstruct_eq_of_le_of_ge @reconstruct_aux lep gep
| .(_) .(_) (@ineq_of_eq_and_ineq_lhs _ _ _ _ c' ep ip) := reconstruct_ineq_of_eq_and_ineq_lhs @sfpr c' ep ip
| .(_) .(_) (@ineq_of_eq_and_ineq_rhs _ _ _ _ c' ep ip) := reconstruct_ineq_of_eq_and_ineq_rhs @sfpr c' ep ip
| .(_) .(_) (@ineq_of_ineq_and_eq_zero_rhs _ _ _ c ip sp) := reconstruct_ineq_of_ineq_and_eq_zero_rhs c ip sp
| .(_) .(_) (@diseq_of_strict_ineq _ _ sp) := reconstruct_diseq_of_strict_ineq @reconstruct_aux sp
| .(_) .(_) (@of_sum_form_proof e c _ sp) := reconstruct_of_sum_form_proof @sfpr e c sp
| .(_) .(_) (adhoc _ _ _ t) := t

end sign_proof

namespace sum_form_proof
section
parameter sfrc : Π {sfc}, sum_form_proof sfc → tactic expr
private meta def sprc := @sign_proof.reconstruct_aux @sfrc
private meta def iprc := @ineq_proof.reconstruct_aux @sprc @sfrc
private meta def eprc := @eq_proof.reconstruct_aux @iprc @sfrc

-- assumes lhs < rhs
private meta def reconstruct_of_ineq_proof  :
        Π {lhs rhs iq}, ineq_proof lhs rhs iq → tactic expr | lhs rhs iq ip :=
if expr.lt lhs rhs then reconstruct_of_ineq_proof ip.sym else
--trace "ipp is:" >> iprc ip >>= infer_type >>= trace >> trace "const is:" >> infer_type ↑`(@polya.mul_lt_of_lt) >>= trace >>
match iq.to_slope with
| slope.horiz :=
  do ipp ← iprc ip,
     tactic.mk_mapp (sum_form_name_of_comp_single iq.to_comp) [none, none, ipp]
| slope.some m :=
  do ipp ← iprc ip,
--trace ("ipp", ip, ipp), infer_type ipp >>= trace, trace ("comp", iq.to_comp), trace ("iq", iq),
     if m = 0 then
       tactic.mk_mapp (sum_form_name_of_comp_single iq.to_comp) [none, none, ipp]
     else
       tactic.mk_mapp (sum_form_name_of_comp iq.to_comp) [none, none, none, ipp]
--     tactic.mk_mapp ((if m = 0 then sum_form_name_of_comp_single else sum_form_name_of_comp) iq.to_comp) [none, none, ipp]
end
--include sfrc

private meta def reconstruct_of_eq_proof  :
        Π {lhs rhs c}, eq_proof lhs rhs c → tactic expr | lhs rhs c ep :=
if expr.lt lhs rhs then reconstruct_of_eq_proof ep.sym else
do ipp ← eprc ep,
   mk_app ``sub_eq_zero_of_eq [ipp]
--fail "sum_form_proof.reconstruct_of_eq_proof not implemented yet"

private meta def reconstruct_of_sign_proof :
        Π {e c}, sign_proof e c → tactic expr | e c sp :=
if c.is_less then sprc sp
else do spp ← sprc sp,
  --trace "spp type is", infer_type spp >>= trace,
  mk_mapp ``rev_op_zero_of_op [none, none, none, some spp]
--fail "sum_form_proof.reconstruct_of_sign_proof not implemented yet"

--  sum_form_proof ⟨lhs.add_factor rhs m, spec_comp.strongest c1 c2⟩
-- wait for algebraic normalizer?
-- TODO
private theorem reconstruct_of_add_factor_aux (P : Prop) {Q R : Prop} (h : Q) (h2 : R) : P := sorry

private meta def reconstruct_of_add_factor_same_comp {lhs rhs c1 c2} (m : ℚ)
        (sfpl : sum_form_proof ⟨lhs, c1⟩) (sfpr : sum_form_proof ⟨rhs, c2⟩) : tactic expr :=
let sum := lhs + rhs.scale m in
do tp ← sum_form.to_expr sum,
   tp' ← (spec_comp.strongest c1 c2).to_comp.to_function tp `(0 : ℚ),
   pf1 ← sfrc sfpl, pf2 ← sfrc sfpr,
   mk_mapp ``reconstruct_of_add_factor_aux [some tp', none, none, some pf1, some pf2] --to_expr `(sorry : %%tp)
--fail "reconstruct_of_add_factor_same_comp failed, not implemented yet"

private theorem reconstruct_of_add_eq_factor_op_comp_aux  (P : Prop) {Q R : Prop} (h : Q) (h2 : R) : P := sorry

/-
m is negative
-/
private meta def reconstruct_of_add_eq_factor_op_comp {lhs rhs c1} (m : ℚ)
        (sfpl : sum_form_proof ⟨lhs, c1⟩) (sfpr : sum_form_proof ⟨rhs, spec_comp.eq⟩) : tactic expr :=
let sum := lhs + rhs.scale m in
do tp ← sum_form.to_expr sum,
   tp' ← c1.to_comp.to_function tp `(0 : ℚ),
   pf1 ← sfrc sfpl, pf2 ← sfrc sfpr,
   mk_mapp ``reconstruct_of_add_eq_factor_op_comp_aux [some tp', none, none, some pf1, some pf2]
--fail "reconstruct_of_add_eq_factor_op_comp not implemented yet"

private theorem reconstruct_of_scale_aux (P : Prop) {Q : Prop} (h : Q) : P := sorry

private meta def reconstruct_of_scale (rct : Π {sfc}, sum_form_proof sfc → tactic expr)
        {sfc} (m : ℚ) (sfp : sum_form_proof sfc) : tactic expr :=
do tp ← sum_form.to_expr (sfc.sf.scale m),
   tp' ← sfc.c.to_comp.to_function tp `(0 : ℚ),
   pf ← rct sfp,
   mk_mapp ``reconstruct_of_scale_aux [some tp', none, some pf] -- to_expr `(sorry : %%tp')

end

-- TODO (alg norm)
theorem reconstruct_of_expr_def_aux (P : Prop) : P := sorry

private meta def reconstruct_of_expr_def (e : expr) (sf : sum_form) : tactic expr :=
do tp ← sum_form.to_expr sf,
   tp' ← to_expr ``(%%tp = 0),
--   (_, pf) ← solve_aux tp' (simp >> done),
   mk_app ``reconstruct_of_expr_def_aux [tp']
--   instantiate_mvars pf
--fail "reconstruct_of_expr_def failed, not implemented yet"

meta def reconstruct : Π {sfc}, sum_form_proof sfc → tactic expr
| _ (of_ineq_proof ip) := reconstruct_of_ineq_proof @reconstruct ip
| _ (of_eq_proof ep) := reconstruct_of_eq_proof @reconstruct ep
| _ (of_sign_proof sp) := reconstruct_of_sign_proof @reconstruct sp
| _ (of_add_factor_same_comp m sfpl sfpr) :=
  reconstruct_of_add_factor_same_comp @reconstruct m sfpl sfpr
| _ (of_add_eq_factor_op_comp m sfpl sfpr) :=
  reconstruct_of_add_eq_factor_op_comp @reconstruct m sfpl sfpr
| _ (of_scale m sfp) := reconstruct_of_scale @reconstruct m sfp
| _ (of_expr_def e sf) := reconstruct_of_expr_def e sf
| _ (fake sd) := fail "cannot reconstruct a fake proof"

/-meta def reconstruct : Π {sfc}, sum_form_proof sfc → tactic expr | sfc sfp :=
if sfc.sf.keys.length = 0 then do
 ex ← sfc.c.to_comp.to_function ```(0 : ℚ) ```(0 : ℚ),
 to_expr `(sorry : %%ex) else
let sfcd : sum_form_comp_data := ⟨_, sfp, mk_rb_set⟩ in
match sfcd.to_ineq_data with
| option.some ⟨lhs, rhs, id⟩ := do ex ← ineq_data.to_expr id, to_expr `(sorry : %%ex)
| none := trace sfc >> fail "fake sum_form_proof.reconstruct failed, no ineq data"
end-/

end sum_form_proof

meta def sign_proof.reconstruct := @sign_proof.reconstruct_aux @sum_form_proof.reconstruct
meta def ineq_proof.reconstruct := @ineq_proof.reconstruct_aux @sign_proof.reconstruct @sum_form_proof.reconstruct
meta def eq_proof.reconstruct := @eq_proof.reconstruct_aux @ineq_proof.reconstruct @sum_form_proof.reconstruct

meta def ineq_data.to_expr {lhs rhs} (id : ineq_data lhs rhs) : tactic expr :=
match id.inq.to_slope with
| slope.horiz := id.inq.to_comp.to_function rhs `(0 : ℚ)
| slope.some m := if m = 0 then id.inq.to_comp.to_function lhs `(0 : ℚ)
                  else do rhs' ← to_expr ``(%%(m.reflect : expr)*%%rhs), id.inq.to_comp.to_function lhs rhs'
end

namespace contrad

private meta def reconstruct_eq_diseq {lhs rhs} (ed : eq_data lhs rhs) (dd : diseq_data lhs rhs) : tactic expr :=
if bnot (ed.c = dd.c) then fail "reconstruct_eq_diseq failed: given different coefficients"
else do ddp ← dd.prf.reconstruct, edp ← ed.prf.reconstruct, return $ ddp.app edp

private meta def reconstruct_two_ineq_data {lhs rhs} (rct : contrad → tactic expr) (id1 id2 : ineq_data lhs rhs) : tactic expr :=
let sfid1 := sum_form_comp_data.of_ineq_data id1,
    sfid2 := sum_form_comp_data.of_ineq_data id2 in
match find_contrad_in_sfcd_list [sfid1, sfid2] with
| some ctr    := rct ctr
| option.none := fail "reconstruct_two_ineq_data failed to find contr"
end

private meta def reconstruct_eq_ineq {lhs rhs} (ed : eq_data lhs rhs) (id : ineq_data lhs rhs) : tactic expr :=
fail "reconstruct_eq_ineq not implemented"

-- TODO: this is the hard part. Should this be refactored into smaller pieces?
private meta def reconstruct_ineqs (rct : contrad → tactic expr) {lhs rhs} (ii : ineq_info lhs rhs) (id : ineq_data lhs rhs) : tactic expr := --do trace "ineqs!!",
match ii with
| ineq_info.no_comps := fail "reconstruct_ineqs cannot find a contradiction with no known comps"
| ineq_info.one_comp id2 := reconstruct_two_ineq_data rct id id2
| ineq_info.equal ed := reconstruct_eq_ineq ed id
| ineq_info.two_comps id1 id2 :=
   let sfid  := sum_form_comp_data.of_ineq_data id,
       sfid1 := sum_form_comp_data.of_ineq_data id1,
       sfid2 := sum_form_comp_data.of_ineq_data id2 in
   match find_contrad_in_sfcd_list [sfid, sfid1, sfid2] with
   | some ctr    := rct ctr
   | option.none := fail "reconstruct_ineqs failed to find contr"
   end
end

private meta def reconstruct_sign_ne_eq {e} (nepr : sign_proof e gen_comp.ne) (eqpr : sign_proof e gen_comp.eq) : tactic expr :=
do neprp ← nepr.reconstruct, eqprp ← eqpr.reconstruct,
   return $ neprp.app eqprp

private meta def reconstruct_sign_le_gt {e} (lepr : sign_proof e gen_comp.le) (gtpr : sign_proof e gen_comp.gt) : tactic expr :=
do leprp ← lepr.reconstruct, gtprp ← gtpr.reconstruct,
   mk_app ``le_gt_contr [leprp, gtprp]

private meta def reconstruct_sign_ge_lt {e} (gepr : sign_proof e gen_comp.ge) (ltpr : sign_proof e gen_comp.lt) : tactic expr :=
do geprp ← gepr.reconstruct, ltprp ← ltpr.reconstruct,
   mk_app ``ge_lt_contr [geprp, ltprp]

private meta def reconstruct_sign_gt_lt {e} (gtpr : sign_proof e gen_comp.gt) (ltpr : sign_proof e gen_comp.lt) : tactic expr :=
do gtprp ← gtpr.reconstruct, ltprp ← ltpr.reconstruct,
   mk_app ``gt_lt_contr [gtprp, ltprp]

private meta def reconstruct_sign {e} : sign_data e → sign_data e → tactic expr
| ⟨gen_comp.ne, prf1⟩ ⟨gen_comp.eq, prf2⟩ := reconstruct_sign_ne_eq prf1 prf2
| ⟨gen_comp.eq, prf1⟩ ⟨gen_comp.ne, prf2⟩ := reconstruct_sign_ne_eq prf2 prf1
| ⟨gen_comp.le, prf1⟩ ⟨gen_comp.gt, prf2⟩ := reconstruct_sign_le_gt prf1 prf2
| ⟨gen_comp.gt, prf1⟩ ⟨gen_comp.le, prf2⟩ := reconstruct_sign_le_gt prf2 prf1
| ⟨gen_comp.lt, prf1⟩ ⟨gen_comp.ge, prf2⟩ := reconstruct_sign_ge_lt prf2 prf1
| ⟨gen_comp.ge, prf1⟩ ⟨gen_comp.lt, prf2⟩ := reconstruct_sign_ge_lt prf1 prf2
| ⟨gen_comp.gt, prf1⟩ ⟨gen_comp.lt, prf2⟩ := reconstruct_sign_gt_lt prf1 prf2
| ⟨gen_comp.lt, prf1⟩ ⟨gen_comp.gt, prf2⟩ := reconstruct_sign_gt_lt prf2 prf1
| s1 s2 := trace e >> trace s1.c >> trace s2.c >> fail "reconstruct_sign failed: given non-opposite comps"

private meta def reconstruct_strict_ineq_self {e} (id : ineq_data e e) : tactic expr :=
match id.inq.to_comp, id.inq.to_slope with
| comp.gt, slope.some m :=
  if bnot (m = 1) then fail "reconstruct_strict_ineq_self failed: given non-one slope"
  else do idp ← id.prf.reconstruct,
       mk_app ``gt_self_contr [idp]
| comp.lt, slope.some m :=
  if bnot (m = 1) then fail "reconstruct_strict_ineq_self failed: given non-one slope"
  else do idp ← id.prf.reconstruct,
       mk_app ``lt_self_contr [idp]
| _, _ := fail "reconstruct_strict_ineq_self failed: given non-strict comp or non-one slope"
end

meta def reconstruct_sum_form {sfc} (sfp : sum_form_proof sfc) : tactic expr :=
if sfc.is_contr then do
  zltz ← sfp.reconstruct,
  mk_mapp ``lt_irrefl [option.none, option.none, option.none, some zltz]
else fail "reconstruct_sum_form requires proof of 0 < 0"

meta def reconstruct : contrad → tactic expr
| none := fail "cannot reconstruct contr: no contradiction is known"
| (@eq_diseq lhs rhs ed dd) := reconstruct_eq_diseq ed dd
| (@ineqs lhs rhs ii id) := reconstruct_ineqs reconstruct ii id
| (@sign e sd1 sd2) := reconstruct_sign sd1 sd2
| (@strict_ineq_self e id) := reconstruct_strict_ineq_self id
| (@sum_form _ sfp) := reconstruct_sum_form sfp

end contrad

namespace prod_form_proof

/-private meta def mk_prod_ne_zero_prf_aux : expr → list (Σ e : expr, sign_proof e gen_comp.ne) → tactic expr
| e [] := return e
| e (⟨e', sp⟩::t) := do ene ← sp.reconstruct, pf ← mk_app ``mul_ne_zero [e, ene], mk_prod_ne_zero_prf_aux pf t

private meta def mk_prod_ne_zero_prf (c : ℚ) : list (Σ e : expr, sign_proof e gen_comp.ne) → tactic expr
| [] := if c = 0 then fail "mk_prod_ne_zero_prf failed, c = 0" else mk_app ``fake_ne_zero_pf [`(c)]
| (⟨e, sp⟩::t) :=
  if c = 0 then fail "mk_prod_ne_zero_prf failed, c = 0" else
  do cprf ← mk_app ``fake_ne_zero_pf [`(c)],
     hpf ← sp.reconstruct,
     prodprf ← mk_prod_ne_zero_prf_aux hpf t,
     mk_app ``mul_ne_zero [hpf, prodprf]
-/
/-#check spec_comp_and_flipped_of_comp
-- not finished: need to orient c
private meta def reconstruct_of_ineq_proof_pos_lhs {lhs rhs iq} (id : ineq_proof lhs rhs iq)
        (sp : sign_proof lhs gen_comp.gt) (nzprs : hash_map expr (λ e, sign_proof e gen_comp.ne)) : tactic expr :=
match (spec_comp_and_flipped_of_comp iq.to_comp), iq.to_slope with
| _, slope.horiz := fail "reconstruct_of_ineq_proof_pos_lhs failed, cannot make a prod_form with 0 slope"
| (c, flipped), slope.some m :=
  if m = 0 then fail "reconstruct_of_ineq_proof_pos_lhs failed, cannot make a prod_form with 0 slope"
  else do -- lhs c m*rhs --> 1 c m*(lhs⁻¹*rhs)
     idp ← id.reconstruct,
     spp ← sp.reconstruct,
     opp ← mk_app ``one_op_inv_mul_of_op_of_pos [idp, spp], -- 1 r lhs⁻¹*rhs
     if bnot flipped then
        return opp
     else do
        mprf ← mk_sign_pf m,
        failed
end-/

private meta def reconstruct_of_ineq_proof_aux {lhs rhs iq c1 c2} (id : ineq_proof lhs rhs iq)
        (spl : sign_proof lhs c1) (spr : sign_proof rhs c2) (fail_cond : ℚ → bool)
        (unflipped_name flipped_name : name) --flipped_lt_name flipped_le_name : name)
       : tactic expr :=
match (spec_comp_and_flipped_of_comp iq.to_comp), iq.to_slope with
| _, slope.horiz := fail "reconstruct_of_ineq_proof_pos_pos failed, cannot make a prod_form with 0 slope"
| (c, flipped), slope.some m := --trace "okay, roipa" >> trace flipped >> trace iq >>
   if fail_cond m then fail "reconstruct_of_ineq_proof_aux failed check"
   else do
     idp ← id.reconstruct, --trace "idp_type:", infer_type idp >>= trace,
     splp ← spl.reconstruct, --trace "splp_type:", infer_type splp >>= trace, trace "c1 is:", trace c1, trace spl,
     opp ← mk_app unflipped_name [idp, splp],
     --trace "opp", infer_type opp >>= trace,
     if bnot flipped then return opp
     else do
        msgn ← mk_sign_pf m,
        sprp ← spr.reconstruct,
        trace "HERE", infer_type opp >>= trace, infer_type splp >>= trace, infer_type sprp >>= trace, infer_type msgn >>= trace, trace unflipped_name, trace iq,
        mk_app flipped_name-- (if c=spec_comp.lt then flipped_lt_name else flipped_le_name)
               [opp, splp, sprp, msgn]
end

private meta def reconstruct_of_ineq_proof_pos_pos {lhs rhs iq} (id : ineq_proof lhs rhs iq)
        (spl : sign_proof lhs gen_comp.gt) (spr : sign_proof rhs gen_comp.gt) : tactic expr :=
reconstruct_of_ineq_proof_aux id spl spr (λ m, m ≤ 0)
  ``one_op_inv_mul_of_op_of_pos ``one_op_inv_mul_of_lt_of_pos_pos_flipped' -- ``one_le_inv_mul_of_le_of_pos_pos_flipped
/-match (spec_comp_and_flipped_of_comp iq.to_comp), iq.to_slope with
| _, slope.horiz := fail "reconstruct_of_ineq_proof_pos_pos failed, cannot make a prod_form with 0 slope"
| (c, flipped), slope.some m :=
   if m ≤ 0 then fail "reconstruct_of_ineq_proof_pos_pos failed, m ≤ 0"
   else do
     idp ← id.reconstruct,
     splp ← spl.reconstruct,
     opp ← mk_app ``one_op_inv_mul_of_op_of_pos [idp, splp],
     if bnot flipped then return opp
     else do
        msgn ← mk_sign_pf m,
        sprp ← spr.reconstruct,
        mk_app (if c=spec_comp.lt then ``one_lt_inv_mul_of_lt_of_pos_flipped
                 else ``one_le_inv_mul_of_le_of_pos_flipped)
               [opp, splp, sprp, msgn]
end-/

private meta def reconstruct_of_ineq_proof_pos_neg {lhs rhs iq} (id : ineq_proof lhs rhs iq)
        (spl : sign_proof lhs gen_comp.gt) (spr : sign_proof rhs gen_comp.lt) : tactic expr :=
reconstruct_of_ineq_proof_aux id spl spr (λ m, m ≥ 0)
  ``one_op_inv_mul_of_op_of_pos ``one_op_inv_mul_of_lt_of_pos_neg_flipped -- ``one_le_inv_mul_of_le_of_pos_neg_flipped

private meta def reconstruct_of_ineq_proof_neg_pos {lhs rhs iq} (id : ineq_proof lhs rhs iq)
        (spl : sign_proof lhs gen_comp.lt) (spr : sign_proof rhs gen_comp.gt) : tactic expr :=
reconstruct_of_ineq_proof_aux id spl spr (λ m, m ≥ 0)
  ``one_op_inv_mul_of_op_of_neg ``one_op_inv_mul_of_lt_of_neg_pos_flipped -- ``one_le_inv_mul_of_le_of_neg_flipped

private meta def reconstruct_of_ineq_proof_neg_neg {lhs rhs iq} (id : ineq_proof lhs rhs iq)
        (spl : sign_proof lhs gen_comp.lt) (spr : sign_proof rhs gen_comp.lt) : tactic expr :=
reconstruct_of_ineq_proof_aux id spl spr (λ m, m ≤ 0)
  ``one_op_inv_mul_of_op_of_neg ``one_op_inv_mul_of_lt_of_neg_neg_flipped

/-
pos_neg
cmatch (spec_comp_and_flipped_of_comp iq.to_comp), iq.to_slope with
| _, slope.horiz := fail "reconstruct_of_ineq_proof_pos_pos failed, cannot make a prod_form with 0 slope"
| (c, flipped), slope.some m :=
   if m ≥ 0 then fail "reconstruct_of_ineq_proof_pos_neg failed, m ≥ 0"
   else do
     idp ← id.reconstruct,
     splp ← spl.reconstruct,
     opp ← mk_app ``one_op_inv_mul_of_op_of_pos [idp, splp],
     if bnot flipped then return opp
     else do
        msgn ← mk_sign_pf m,
        sprp ← spr.reconstruct,
        mk_app (if c=spec_comp.lt then ``one_lt_inv_mul_of_lt_of_pos_flipped
                 else ``one_le_inv_mul_of_le_of_pos_flipped)
               [opp, splp, sprp, msgn]
end -/

private meta def reconstruct_of_ineq_proof {lhs rhs iq} (id : ineq_proof lhs rhs iq) :
        Π {cl cr}, sign_proof lhs cl → sign_proof rhs cr → tactic expr
| gen_comp.gt gen_comp.gt spl spr := reconstruct_of_ineq_proof_pos_pos id spl spr
| gen_comp.gt gen_comp.lt spl spr := reconstruct_of_ineq_proof_pos_neg id spl spr
| gen_comp.lt gen_comp.gt spl spr := reconstruct_of_ineq_proof_neg_pos id spl spr
| gen_comp.lt gen_comp.lt spl spr := reconstruct_of_ineq_proof_neg_neg id spl spr
| _ _ _ _ := fail "reconstruct_of_ineq_proof failed, need to know signs of components"

/-
-- TODO
private meta def reconstruct_of_ineq_proof_neg_lhs {lhs rhs iq} (id : ineq_proof lhs rhs iq)
        (sp : sign_proof lhs gen_comp.lt) (nzprs : hash_map expr (λ e, sign_proof e gen_comp.ne)) : tactic expr :=
match iq.to_slope with
| slope.horiz := fail "reconstruct_of_ineq_proof_neg_lhs failed, cannot make a prod_form with 0 slope"
| slope.some m :=
  if m = 0 then fail "reconstruct_of_ineq_proof_pos_lhs failed, cannot make a prod_form with 0 slope"
  else
  failed
end-/

private meta def reconstruct_of_eq_proof {lhs rhs c} (id : eq_proof lhs rhs c)
        (lhsne : sign_proof lhs gen_comp.ne) : tactic expr :=
if c = 0 then fail "reconstruct_of_eq_proof failed, cannot make a prod_form with 0 slope"
else do
  lhsnep ← lhsne.reconstruct,
  idpf ← id.reconstruct,
  mk_app ``one_eq_div_of_eq [idpf, lhsnep]

theorem reconstruct_of_expr_def_aux (P : Prop) : P := sorry

/-

-- TODO

private meta def reconstruct_of_expr_def (e : expr) (sf : sum_form) : tactic expr :=
do tp ← sum_form.to_expr sf,
   tp' ← to_expr ``(%%tp = 0),
--   (_, pf) ← solve_aux tp' (simp >> done),
   mk_app ``reconstruct_of_expr_def_aux [tp']
--   instantiate_mvars pf
--fail "reconstruct_of_expr_def failed, not implemented yet"
-/

-- TODO (alg_nom)
private meta def reconstruct_of_expr_def (e : expr) (pf : prod_form) : tactic expr :=
do --trace "in reconstruct_of_expr_def",
   tp ← prod_form.to_expr pf,
 --  trace "tp:", trace tp,
   tp' ← to_expr ``(1 = %%tp),
 --  trace "tp':", trace tp',
--   (_, pf) ← solve_aux tp' (simp >> done),
   mk_app ``reconstruct_of_expr_def_aux [tp']

section
variable (rct : Π {pfc}, prod_form_proof pfc → tactic expr)

-- Given an expr of the form e := (p1^e1)^k, produces a proof that
-- e = p1^(e1*k)
private meta def simp_pow_aux_aux (p e k : expr) : tactic expr :=
mk_app ``rat.pow_pow [p, e, k]

/-private meta def simp_pow_aux_aux : expr → tactic expr
| `(rat.pow (rat.pow %%p %%e) %%k) := mk_app ``rat.pow_pow [p, e, k]
| _ := failed
-/

-- Given an expr of the form e := (p1^e1*...*pn^en)^k, produces a proof that
-- e = (p1^(e1*k) * ... * pn^(en*k)
private meta def simp_pow_aux : expr → tactic expr | e :=
match e with
| `(rat.pow (%%a * (rat.pow %%b %%n)) %%k) :=
  let prod' := `(rat.pow %%a %%k) in
  do prod_pf ← simp_pow_aux prod',
     pow_pf ← mk_app ``rat.mul_pow [a, `(rat.pow %%b %%n), k],
     one_pow_pf ← simp_pow_aux_aux b n k,
--     trace "doing rewrite",
--     infer_type pow_pf >>= trace, trace e,
     (e', pf1, []) ← rewrite pow_pf e,
     (e'', pf2, []) ← rewrite one_pow_pf e',
     (e''', pf3, []) ← rewrite prod_pf e'',
     t1 ← mk_app ``eq.trans [pf1, pf2],
     mk_app ``eq.trans [t1, pf3]
| `(rat.pow (rat.pow %%a %%n) %%k) :=
  simp_pow_aux_aux a n k
| e := do f ← pp e, fail $ "simp_pow_aux failed on " ++ f.to_string
end

-- Given an expr of the form e := (c*(p1^e1*...*pn^en))^k, produces a proof that
-- e = c^k * (p1^(e1*k) * ... * pn^(en*k))
meta def simp_pow (e : expr) :  tactic expr :=
--do trace "simp pow called on:", trace e,
match e with
| `(rat.pow (%%coeff * %%prod) %%k) :=
  let prod' := `(rat.pow %%prod %%k) in
  do prod_pf ← simp_pow_aux prod',
     pow_pf ← mk_app ``rat.mul_pow [coeff, prod, k],
     --trace "doing rewrite",
     (e', pf1, []) ← rewrite pow_pf e,
     (e'', pf2, []) ← rewrite prod_pf e',
     mk_app ``eq.trans [pf1, pf2]
| _ := fail "simp_pow got malformed arg"
end

/-example (a b c : ℚ) (m n k : ℤ) : rat.pow (a * (rat.pow b m * rat.pow c n)) k = rat.pow a k * (rat.pow b (m*k) * rat.pow c (n*k)) :=
by do
(lhs, rhs) ← target >>= match_eq,
e ← simp_pow lhs,
infer_type e >>= trace,
exact e-/

private meta def simp_pow_expr (pf tgt : expr) : tactic expr :=
do sls ← (simp_lemmas.mk.add_simp ``rat.mul_pow_rev) >>= λ t, t.add pf,
   --trace "target", trace tgt,
   --trace "pf tp", infer_type pf >>= trace,
   (do (_, npf) ← simplify sls [] tgt,-- <|> do rpr ← to_expr ``(eq.refl %%tgt), return (`(()), rpr),
   --(_, npf) ← solve_aux tgt (simp_target sls >> done),
   return npf) <|> to_expr ``(eq.refl %%tgt)

meta def simp_lemmas.add_simp_list : simp_lemmas → list name → tactic simp_lemmas
| s [] := return s
| s (h::t) := s.add_simp h >>= λ s', simp_lemmas.add_simp_list s' t

private meta def simp_pow_expr' (tgt : expr) : tactic expr :=
do --sls ← (simp_lemmas.mk.add_simp ``rat.mul_pow) >>= (λ s, simp_lemmas.add_simp s ``rat.pow_one) >>= (λ s, simp_lemmas.add_simp s ``rat.pow_neg_one),
   sls ← simp_lemmas.add_simp_list simp_lemmas.mk [``rat.mul_pow, ``rat.pow_one, ``rat.pow_neg_one, ``rat.one_pow, ``rat.pow_pow, ``rat.one_div_pow],
   --trace "target", trace tgt,
--   trace "pf tp", infer_type pf >>= trace,
--   (do (_, npf) ← simplify sls [] tgt,-- <|> do rpr ← to_expr ``(eq.refl %%tgt), return (`(()), rpr),
   (_, npf) ← solve_aux tgt ( /-trace_state >>-/ simp_target sls >>/- trace "!!!" >> trace_state >>-/ reflexivity), -- `[simp [rat.mul_pow_rev, rat.pow_one], done],
   return npf

section
open expr
private meta def reconstruct_of_pow_pos {pfc} (z : ℤ) (pfp : prod_form_proof pfc) : tactic expr :=
if z ≤ 0 then fail "reconstruct_of_pow_pos failed, given negative exponent" else
do zsn ← mk_int_sign_pf z,
   pf1 ← rct pfp,
   --trace "here", /-trace pfc,-/ trace pfp, trace z, infer_type pf1 >>= trace,
   pf2 ← mk_mapp (if pfc.c = spec_comp.lt then ``lt_pos_pow' else ``le_pos_pow') [none, pf1, none, zsn],
   --trace "pf2tp", infer_type pf2 >>= trace,
   pf2tp ← infer_type pf2,
   match pf2tp with
   | (app (app (app o i) lhs) rhs) :=
    do eqp ← simp_pow rhs,
       (new_type, prf, []) ← rewrite eqp pf2tp,
       mk_eq_mp prf pf2
--       failed
   | _ := fail "reconstruct_of_pow_pos failed"
   end
/-
   match pf2tp with
   | app (app (app o i) lhs) rhs := do tgt ← prod_form.to_expr (pfc.pf.pow z), pf ← to_expr ``(%%rhs = %%tgt) >>= simp_pow_expr',
    trace "pf2tp", trace pf2tp, trace "pftp", infer_type pf >>= trace,
    trace "o", trace o,
--    trace `(%%o %%lhs %%tgt),
    tgt' ← return $ app (app (app o i) lhs) tgt,--to_expr ``(%%o %%lhs %%tgt),
    trace "new tgt:", trace tgt',
    pf1 ← to_expr ``(eq.symm %%pf),
    (_, pf') ← solve_aux tgt' (rewrite_target pf1 >> apply pf2),
    trace "proved", infer_type pf' >>= trace,
    return pf'
   | _ := failed
   end
--   tgt ← prod_form.to_expr (pfc.pf.pow z),
--   simp_pow_expr pf2 tgt -/

end

/-private meta def reconstruct_of_pow_neg {pfc} (z : ℤ) (pfp : prod_form_proof pfc) : tactic expr :=
if z ≥ 0 then fail "reconstruct_of_pow_neg failed, given positive exponent" else
failed-/

private meta def reconstruct_of_pow_eq {pfc} (z : ℤ) (pfp : prod_form_proof pfc) : tactic expr :=
do --trace "pfp is:", trace pfp,
   pf1 ← rct pfp, --trace "reconstructed", infer_type pf1 >>= trace,
   tpf ← mk_app ``eq_pow [pf1, `(z)],
   tpf' ← mk_app ``eq_pow' [tpf],
   tpf_tp ← infer_type tpf',
   tgt ← prod_form.to_expr (pfc.pf.pow z),
   --trace "target is:", trace tgt,
   tgt' ← to_expr ``(1 = %%tgt),
   --trace "tgt', tpf", trace tgt', infer_type tpf >>= trace,
   (_, pf') ← solve_aux tgt' (assertv `h tpf_tp tpf' >> `[simp only [rat.mul_pow, rat.pow_pow], simp only [rat.mul_pow, rat.pow_pow] at h, apply h] >> done),
   return pf'
--   simp_pow_expr tpf tgt

private meta def reconstruct_of_pow {pfc} (z : ℤ) (pfp : prod_form_proof pfc) : tactic expr :=
if pfc.c = spec_comp.eq then reconstruct_of_pow_eq @rct z pfp else reconstruct_of_pow_pos @rct z pfp

private theorem reconstruct_of_mul_aux (P : Prop) {Q R : Prop} : Q → R → P := sorry

private meta def reconstruct_of_mul (rct : Π {pfc}, prod_form_proof pfc → tactic expr)
        {lhs rhs c1 c2} (pfp1 : prod_form_proof ⟨lhs, c1⟩) (pfp2 : prod_form_proof ⟨rhs, c2⟩)
        (sgns : list Σ e : expr, sign_proof e gen_comp.ne) : tactic expr :=
let prod := lhs * rhs in
do /-trace "in reconstruct_of_mul",
   trace prod,-/
   tp  ← prod_form.to_expr prod,
   --trace tp,
   tp' ← (spec_comp.strongest c1 c2).to_comp.to_function `(1 : ℚ) tp,
   --trace tp',
   pf1 ← rct pfp1, pf2 ← rct pfp2,-- trace "**",
   mk_mapp ``reconstruct_of_mul_aux [tp', none, none, pf1, pf2]
/-
let sum := lhs + rhs.scale m in
do tp ← sum_form.to_expr sum,
   tp' ← (spec_comp.strongest c1 c2).to_comp.to_function tp `(0 : ℚ),
   pf1 ← sfrc sfpl, pf2 ← sfrc sfpr,
   mk_mapp ``reconstruct_of_add_factor_aux [some tp', none, none, some pf1, some pf2]
-/

end

meta def reconstruct : Π {pfc}, prod_form_proof pfc → tactic expr
--| .(_) (@of_ineq_proof_pos_lhs _ _ _ id sp nzprs) := reconstruct_of_ineq_proof_pos_lhs id sp nzprs
--| .(_) (@of_ineq_proof_neg_lhs _ _ _ id sp nzprs) := reconstruct_of_ineq_proof_neg_lhs id sp nzprs
| .(_) (@of_ineq_proof _ _ _ _ _ id spl spr) := reconstruct_of_ineq_proof id spl spr
| .(_) (@of_eq_proof _ _ _ id lhsne) := reconstruct_of_eq_proof id lhsne
| .(_) (@of_expr_def e pf) := reconstruct_of_expr_def e pf
| .(_) (@of_pow _ z pfp) := reconstruct_of_pow @reconstruct z pfp
| .(_) (@of_mul _ _ _ _ pfp1 pfp2 sgns) := reconstruct_of_mul @reconstruct pfp1 pfp2 sgns
| .(_) (adhoc _ _ t) := t
| .(_) (fake _) := fail "prod_form_proof.reconstruct failed: cannot reconstruct fake"

end prod_form_proof

end polya