-- /-
-- Copyright (c) 2020 Wojciech Nawrocki. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Wojciech Nawrocki
-- -/

-- import category_theory.limits.shapes.finite_products
-- import category_theory.limits.shapes.binary_products
-- import category_theory.limits.shapes.terminal
-- import tactic.rcases
-- import pfin

-- /-! # Stuff that should be in the catthy library. -/
-- namespace category_theory

-- universes w w₁
-- -- def discrete.equiv_of_iso {J : Type w} {K : Type w₁} (h : J ≃ K) : (discrete J ≌ discrete K) :=
-- -- equivalence.mk
-- --   (functor.of_function h.to_fun) -- C ⥤ D
-- --   (functor.of_function h.inv_fun) -- D ⥤ C
-- --   { hom := {
-- --       app := λ X, begin
-- --         apply eq_to_hom,
-- --         simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
-- --         exact (h.left_inv X).symm,
-- --       end,
-- --       naturality' := λ X Y f, dec_trivial },
-- --     inv := {
-- --       app := λ X, begin
-- --         apply eq_to_hom,
-- --         simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
-- --         exact h.left_inv X,
-- --       end,
-- --       naturality' := λ X Y f, dec_trivial },
-- --     hom_inv_id' := by ext1; exact dec_trivial,
-- --     inv_hom_id' := by ext1; exact dec_trivial }
-- --   { hom := {
-- --       app := λ X, begin
-- --         apply eq_to_hom,
-- --         simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
-- --         exact h.right_inv X
-- --       end,
-- --       naturality' := λ X Y f, dec_trivial },
-- --     inv := {
-- --       app := λ X, begin
-- --         apply eq_to_hom,
-- --         simp only [functor.id_obj, functor.of_function_obj, functor.comp_obj],
-- --         exact (h.right_inv X).symm,
-- --       end,
-- --       naturality' := λ X Y f, dec_trivial },
-- --     hom_inv_id' := by ext1; exact dec_trivial,
-- --     inv_hom_id' := by ext1; exact dec_trivial }

-- namespace limits

-- universes v u
-- variables {C : Type u} [𝒞 : category.{v} C]
-- include 𝒞

-- lemma prod.lift_uniq {X Y Z : C} [has_limit (pair X Y)] (f : Z ⟶ X) (g : Z ⟶ Y) (m : Z ⟶ X ⨯ Y)
--   (hLeft : m ≫ prod.fst = f) (hRight : m ≫ prod.snd = g)
--   : m = prod.lift f g :=
-- begin
--   apply limit.hom_ext,
--   intro j,
--   cases hLeft, cases hRight, cases j,
--     simp only [limit.lift_π, binary_fan.mk_π_app_left],
--   simp only [limit.lift_π, binary_fan.mk_π_app_right],
-- end

-- end limits
-- end category_theory

-- /-!
-- # Constructing finite products from binary products and a terminal object

-- If a category has all binary products, and a terminal object, then it has all finite products.
-- -/

-- namespace category_theory.limits
-- open category_theory

-- universes v u
-- variables {C : Type u} [𝒞 : category.{v} C]
-- include 𝒞

-- -- We hide the "implementation details" inside a namespace
-- namespace has_finite_products_of_binary_products_and_terminal_object

-- @[reducible]
-- def match_statement_lol [has_binary_products.{v} C]
--   {n : ℕ} (F: discrete (pfin (nat.succ n)) ⥤ C) (limF' : has_limit (discrete.lift pfin.succ ⋙ F))
--   : Π (j: pfin (nat.succ n)), F.obj ⟨0, nat.succ_pos n⟩ ⨯ limF'.cone.X ⟶ F.obj j
-- | ⟨0, _⟩ := prod.fst
-- | w@⟨nat.succ j, _⟩ := prod.snd ≫
--   limF'.cone.π.app (w.pred (λ h, nat.succ_ne_zero j (pfin.veq_of_eq h)))

-- set_option eqn_compiler.zeta true
-- def has_limit_for_pfin_diagram [has_binary_products.{v} C] [has_terminal.{v} C]
-- : Π {n: ℕ} (F: (discrete (pfin n)) ⥤ C)
-- , has_limit F
-- | 0 F :=
--   -- In the base case, the category of cones over a diagram of shape ∅ is simply 𝒞, so
--   -- the limit cone is 𝒞's terminal object.
--   let absurdJ (x : pfin 0) : false := x.elim0 in
--   let myCone : cone F :=
--     { X := terminal C,
--       π := nat_trans.of_homs (λ j, (absurdJ j).elim) } in
--   { cone := myCone,
--     is_limit :=
--       { lift := λ s, terminal.from s.X
--       , fac' := λ s j, (absurdJ j).elim
--       , uniq' := λ s m h, dec_trivial } }

-- | (nat.succ n) F :=
--   -- In the inductive case, we construct a limit cone with apex (F 0) ⨯ (apex of smaller limit cone)
--   -- where the smaller cone is obtained from the below functor.
--   let F' : discrete (pfin n) ⥤ C := discrete.lift pfin.succ ⋙ F in
--   let limF' : has_limit F' := has_limit_for_pfin_diagram F' in
--   let myCone : cone F :=
--     { X := (F.obj ⟨0, nat.succ_pos n⟩) ⨯ limF'.cone.X
--     , π := nat_trans.of_homs (match_statement_lol F limF') } in -- TODO(WN): using an actual match statement here
--                                                                 -- is hard to unfold later, but would obv be nicer.
--   { cone := myCone,
--     is_limit :=
--       { lift := λ s,
--           -- Show that s.X is also the apex of a cone over F' ..
--           let s' : cone F' :=
--             { X := s.X
--             , π := nat_trans.of_homs (λ j, s.π.app j.succ) } in
--           -- .. in order to get from s.X to limF'.cone.X in the right morphism
--           -- using the fact that limF' is a limit cone over F'.
--           prod.lift
--             (s.π.app $ ⟨0, nat.succ_pos n⟩)
--             (eq_to_hom rfl ≫ limF'.is_limit.lift s')
--       -- Show that lift is in fact a morphism of cones from s into myCone.
--       , fac' := λ s j, begin
--         rcases j with ⟨j, hj⟩, cases j;
--         simp only [category.id_comp, nat_trans.of_homs_app, eq_to_hom_refl, match_statement_lol,
--           prod.lift_fst, limit.lift_π_assoc, is_limit.fac, nat_trans.of_homs_app,
--           binary_fan.mk_π_app_right], congr
--       end
--       -- Show that lift is the unique morphism into myCone.
--       , uniq' := λ s m h, begin
--         have h0 := h ⟨0, nat.succ_pos n⟩,
--         simp [match_statement_lol] at h0,
--         let s' : cone F' :=
--           { X := s.X
--           , π := nat_trans.of_homs (λ j, s.π.app j.succ) },
--         have hS : m ≫ prod.snd = eq_to_hom rfl ≫ limF'.is_limit.lift s',
--         { -- m ≫ prod.snd is a morphism of cones over F' into limF'.X ..
--           have hN : ∀ (j: discrete (pfin n)), (m ≫ prod.snd) ≫ limF'.cone.π.app j = s'.π.app j,
--           { intro j,
--             unfold_projs, simp [(h j.succ).symm],
--             rcases j with ⟨j, hj⟩, refl },
--           -- .. and therefore unique.
--           have hUniq' : m ≫ prod.snd = limF'.is_limit.lift s',
--           from limF'.is_limit.uniq' s' (m ≫ prod.snd) hN,
--           simp only [hUniq', category.id_comp, eq_to_hom_refl] },
--         exact prod.lift_uniq _ _ _ h0 hS
--       end } }
-- set_option eqn_compiler.zeta false

-- end has_finite_products_of_binary_products_and_terminal_object

-- open has_finite_products_of_binary_products_and_terminal_object

-- -- TODO(WN): instance or def? Is there another way one might want to construct limits of shape pfin?
-- instance has_limits_of_shape_pfin [has_binary_products.{v} C] [has_terminal.{v} C] (n : ℕ)
--   : @has_limits_of_shape (discrete $ pfin n) _ C 𝒞 :=
-- ⟨λ F, has_limit_for_pfin_diagram F⟩

-- -- TODO(WN): trunc? #22
-- def has_trunc_finite_products [has_binary_products.{v} C] [has_terminal.{v} C]
--   {J : Type v} [fintype J] [decidable_eq J]
--   : trunc (has_limits_of_shape (discrete J) C) :=
-- trunc.lift_on (fintype.equiv_pfin J)
--   (λ h,
--     let hIso : discrete (pfin $ fintype.card J) ≌ discrete J :=
--       discrete.equiv_of_iso h.symm in
--     let limsPfin : @has_limits_of_shape (discrete (pfin $ fintype.card J)) _ C 𝒞 :=
--       by apply_instance in
--     trunc.mk $ has_limits_of_shape_of_equivalence hIso)
--   (λ a b, trunc.eq _ _)

-- end category_theory.limits


import for_mathlib.category_theory.functor.shift
import category_theory.localization.predicate

noncomputable theory

open category_theory category_theory.category

namespace category_theory

@[simps]
instance localization.lifting.L_comp {C H D : Type*} [category C] [category H] [category D]
  (L : C ⥤ H) (W : morphism_property C) [L.is_localization W] (F : H ⥤ D) :
  localization.lifting L W (L ⋙ F) F :=
⟨iso.refl _⟩

namespace functor

namespace has_comm_shift

section

variables {C H D : Type*} [category C] [category H] [category D]
  {L : C ⥤ H} {F : C ⥤ D} {G : H ⥤ D} (e : L ⋙ G ≅ F)
  (W : morphism_property C) [L.is_localization W] {A : Type*} [add_monoid A]
  [has_shift C A] [has_shift D A] [has_shift H A]
  [F.has_comm_shift A] [L.has_comm_shift A]

include e W

def of_localization.iso (a : A) : shift_functor H a ⋙ G ≅ G ⋙ shift_functor D a :=
localization.lift_nat_iso L W (L ⋙ (shift_functor H a ⋙ G)) (L ⋙ G ⋙ shift_functor D a) _ _
  ((functor.associator _ _ _).symm ≪≫ iso_whisker_right (L.comm_shift_iso a).symm _ ≪≫
    functor.associator _ _ _ ≪≫ iso_whisker_left _ e ≪≫ F.comm_shift_iso a ≪≫
    iso_whisker_right e.symm  _ ≪≫ functor.associator _ _ _)

@[simp]
lemma of_localization.iso_hom_app_obj (a : A) (X : C) :
  (of_localization.iso e W a).hom.app (L.obj X) =
    G.map ((L.comm_shift_iso a).inv.app X) ≫ e.hom.app ((shift_functor C a).obj X) ≫
      (F.comm_shift_iso a).hom.app X ≫ (shift_functor D a).map (e.inv.app X) :=
begin
  dsimp [of_localization.iso],
  simp only [localization.lift_nat_trans_app, localization.lifting.L_comp_iso, iso.refl_hom,
    nat_trans.id_app, nat_trans.comp_app, associator_inv_app, whisker_right_app,
    associator_hom_app, whisker_left_app, comp_id, id_comp, iso.refl_inv, assoc],
  erw id_comp,
end

@[simp]
lemma of_localization.iso_inv_app_obj (a : A) (X : C) :
  (of_localization.iso e W a).inv.app (L.obj X) =
    (shift_functor D a).map (e.hom.app X) ≫  (F.comm_shift_iso a).inv.app X ≫
    e.inv.app ((shift_functor C a).obj X) ≫ G.map ((L.comm_shift_iso a).hom.app X) :=
begin
  dsimp [of_localization.iso],
  simp only [assoc, localization.lift_nat_trans_app, localization.lifting.L_comp_iso,
    iso.refl_hom, nat_trans.id_app, nat_trans.comp_app, associator_inv_app, whisker_right_app,
    whisker_left_app, associator_hom_app, comp_id, id_comp, iso.refl_inv],
  erw id_comp,
end

variable (A)

@[simps]
def of_localization : G.has_comm_shift A :=
{ iso := of_localization.iso e W,
  iso_zero := begin
    ext1,
    apply localization.nat_trans_ext L W,
    intro X,
    simp only [of_localization.iso_hom_app_obj, comm_shift.unit_hom_app, iso.symm_hom,
      iso.symm_inv, monoidal_functor.ε_iso_hom, F.comm_shift_iso_zero A,
      L.comm_shift_iso_zero A, comm_shift.unit_inv_app, assoc, functor.map_comp,
      ← nat_trans.naturality, ← nat_trans.naturality_assoc, id_map, comp_map],
    congr' 1,
    dsimp,
    simp only [e.hom_inv_id_app_assoc, ← functor.map_comp_assoc, ← functor.map_comp,
      ε_hom_inv_app],
    erw [functor.map_id, functor.map_id, id_comp],
  end,
  iso_add := λ a b, begin
    ext1,
    apply localization.nat_trans_ext L W,
    intro X,
    simp only [of_localization.iso_hom_app_obj, comm_shift.add_hom_app, iso.symm_hom,
      map_comp, iso.symm_inv, monoidal_functor.μ_iso_hom, assoc, μ_naturality,
      functor.comm_shift_iso_add, comm_shift.add_inv_app],
    erw [← nat_trans.naturality_assoc, ← nat_trans.naturality_assoc],
    dsimp,
    simp only [of_localization.iso_hom_app_obj, assoc],
    nth_rewrite 3 ← G.map_comp_assoc,
    erw [← (shift_functor D b).map_comp_assoc, e.inv_hom_id_app, functor.map_id, id_comp,
      ← L.map_comp, μ_hom_inv_app, L.map_id, G.map_id, id_comp],
    refl,
  end, }

include A

lemma of_localization.respects_comm_shift :
  by { letI := of_localization e W A,
    exact e.hom.respects_comm_shift A } :=
begin
  letI := of_localization e W A,
  refine ⟨λ a, _⟩,
  ext X,
  simp only [nat_trans.comp_app, comp_hom_app, whisker_right_app, assoc, whisker_left_app],
  erw of_localization.iso_hom_app_obj e W a X,
  simp only [assoc, ← G.map_comp_assoc, iso.hom_inv_id_app, ← functor.map_comp,
    iso.inv_hom_id_app],
  dsimp,
  simp only [map_id, id_comp, comp_id],
end

end

section

variables {C H D A : Type*}
  [category C] [category H] [category D] [add_monoid A]
  [has_shift C A] [has_shift D A] [has_shift H A] (W : morphism_property C)
  {L : C ⥤ H} {F : C ⥤ D} [L.has_comm_shift A] [F.has_comm_shift A]
  [L.is_localization W] (hF : W.is_inverted_by F)

instance localization_lift_has_comm_shift :
  (localization.lift F hF L).has_comm_shift A :=
of_localization (localization.fac F hF L) W A

instance localization_fac_hom_respects_comm_shift :
  (localization.fac F hF L).hom.respects_comm_shift A :=
of_localization.respects_comm_shift _ _ _

end
end has_comm_shift

end functor

end category_theory


import Yatima.Lean.Utils
import Yatima.ContAddr.ContAddrM
import YatimaStdLib.RBMap
import Lurk.LightData

namespace Yatima.ContAddr

scoped instance : HMul Ordering Ordering Ordering where hMul
  | .gt, _ => .gt
  | .lt, _ => .lt
  | .eq, x => x

def concatOrds : List Ordering → Ordering :=
  List.foldl (· * ·) .eq

open IR
open Std (RBMap)

/-- Defines an ordering for Lean universes -/
def cmpLevel (x : Lean.Level) (y : Lean.Level) : ContAddrM Ordering :=
  match x, y with
  | .mvar .., _ => throw $ .unfilledLevelMetavariable x
  | _, .mvar .. => throw $ .unfilledLevelMetavariable y
  | .zero, .zero => return .eq
  | .zero, _ => return .lt
  | _, .zero => return .gt
  | .succ x, .succ y => cmpLevel x y
  | .succ .., _ => return .lt
  | _, .succ .. => return .gt
  | .max lx ly, .max rx ry => (· * ·) <$> cmpLevel lx rx <*> cmpLevel ly ry
  | .max .., _ => return .lt
  | _, .max .. => return .gt
  | .imax lx ly, .imax rx ry => (· * ·) <$> cmpLevel lx rx <*> cmpLevel ly ry
  | .imax .., _ => return .lt
  | _, .imax .. => return .gt
  | .param x, .param y => do
    let lvls := (← read).univCtx
    match (lvls.indexOf? x), (lvls.indexOf? y) with
    | some xi, some yi => return (compare xi yi)
    | none,    _       => throw $ .levelNotFound x lvls
    | _,       none    => throw $ .levelNotFound y lvls

/-- Content-addresses a Lean universe level and adds it to the store -/
def contAddrUniv : Lean.Level → ContAddrM Univ
  | .zero => pure .zero
  | .succ u => return .succ (← contAddrUniv u)
  | .max a b  => return .max  (← contAddrUniv a) (← contAddrUniv b)
  | .imax a b => return .imax (← contAddrUniv a) (← contAddrUniv b)
  | .param name => do
    let lvls := (← read).univCtx
    match lvls.indexOf? name with
    | some n => pure $ .var n
    | none   => throw $ .levelNotFound name lvls
  | l@(.mvar ..) => throw $ .unfilledLevelMetavariable l

/-- Retrieves a Lean constant from the environment by its name -/
def getLeanConstant (name : Lean.Name) : ContAddrM Lean.ConstantInfo := do
  match (← read).constMap.find? name with
  | some const => pure const
  | none => throw $ .unknownConstant name

def isInternalRec (expr : Lean.Expr) (name : Lean.Name) : Bool :=
  match expr with
  | .forallE _ t e _  => match e with
    | .forallE ..  => isInternalRec e name
    | _ => isInternalRec t name -- t is the major premise
  | .app e .. => isInternalRec e name
  | .const n .. => n == name
  | _ => false

mutual

partial def contAddrConst (const : Lean.ConstantInfo) : ContAddrM Lurk.F := do
  match (← get).env.consts.find? const.name with
  | some hash => pure hash
  | none => match const with
    | .defnInfo val => withLevelsAndReset val.levelParams $ contAddrDefinition val
    | .inductInfo val => withLevelsAndReset val.levelParams $ contAddrInductive val
    | .ctorInfo val => do
      match ← getLeanConstant val.induct with
      | .inductInfo ind => discard $ contAddrConst (.inductInfo ind)
      | const => throw $ .invalidConstantKind const.name "inductive" const.ctorName
      contAddrConst const
    | .recInfo val => do
      match ← getLeanConstant val.getInduct with
      | .inductInfo ind => discard $ contAddrConst (.inductInfo ind)
      | const => throw $ .invalidConstantKind const.name "inductive" const.ctorName
      contAddrConst const
    -- The rest adds the constants to the cache one by one
    | const => withLevelsAndReset const.levelParams do
      let obj ← match const with
        | .defnInfo _ | .inductInfo _ | .ctorInfo _ | .recInfo _ => unreachable!
        | .axiomInfo val =>
          pure $ .axiom ⟨val.levelParams.length, ← contAddrExpr val.type⟩
        | .thmInfo val =>
          -- Theorems are never truly recursive
          pure $ .theorem ⟨val.levelParams.length, ← contAddrExpr val.type,
            ← contAddrExpr val.value⟩
        | .opaqueInfo val =>
          let recrs := .single val.name 0
          pure $ .opaque ⟨val.levelParams.length, ← contAddrExpr val.type,
            ← withRecrs recrs $ contAddrExpr val.value⟩
        | .quotInfo val =>
          pure $ .quotient ⟨val.levelParams.length, ← contAddrExpr val.type, val.kind⟩
      let hash ← commit obj
      addConstToEnv const.name hash
      return hash

partial def contAddrDefinition (struct : Lean.DefinitionVal) : ContAddrM Lurk.F := do
  -- If the mutual size is one, simply content address the single definition
  if struct.all matches [_] then
    let hash ← commit $ .definition
      (← withRecrs (.single struct.name 0) $ definitionToIR struct)
    addConstToEnv struct.name hash
    return hash

  -- Collecting and sorting all definitions in the mutual block
  let mutualDefs ← struct.all.mapM fun name => do
    match ← getLeanConstant name with
    | .defnInfo defn => pure defn
    | const => throw $ .invalidConstantKind const.name "definition" const.ctorName
  let mutualDefs ← sortDefs [mutualDefs]

  -- Building the `recrCtx`
  let mut recrCtx := default
  for (i, ds) in mutualDefs.enum do
    for d in ds do
      recrCtx := recrCtx.insert d.name i

  let definitions ← withRecrs recrCtx $ mutualDefs.mapM (·.mapM definitionToIR)

  -- Building and storing the block
  let definitionsIr := (definitions.map (match ·.head? with
    | some d => [d] | none => [])).join
  let blockHash ← commit $ .mutDefBlock definitionsIr
  addBlockToEnv blockHash

  -- While iterating on the definitions from the mutual block, we need to track
  -- the correct objects to return
  let mut ret? : Option Lurk.F := none

  for name in struct.all do
    -- Storing and caching the definition projection
    -- Also adds the constant to the array of constants
    let some idx := recrCtx.find? name | throw $ .cantFindMutDefIndex name
    let hash ← commit $ .definitionProj ⟨blockHash, idx⟩
    addConstToEnv name hash
    if struct.name == name then ret? := some hash

  match ret? with
  | some ret => return ret
  | none => throw $ .constantNotContentAddressed struct.name

partial def definitionToIR (defn : Lean.DefinitionVal) : ContAddrM Definition :=
  return ⟨defn.levelParams.length, ← contAddrExpr defn.type,
    ← contAddrExpr defn.value, defn.safety == .partial⟩

/--
Content-addresses an inductive and all inductives in the mutual block as a
mutual block, even if the inductive itself is not in a mutual block.

Content-addressing an inductive involves content-addressing its associated
constructors and recursors, hence the lenght of this function.
-/
partial def contAddrInductive (initInd : Lean.InductiveVal) : ContAddrM Lurk.F := do
  -- `mutualConsts` is the list of the names of all constants associated with an inductive block
  -- it has the form: ind₁ ++ ctors₁ ++ recrs₁ ++ ... ++ indₙ ++ ctorsₙ ++ recrsₙ
  let mut inds := []
  let mut indCtors := []
  let mut indRecs := []
  let mut nameData : RBMap Name (List Name × List Name) compare := .empty
  for indName in initInd.all do
    match ← getLeanConstant indName with
    | .inductInfo ind =>
      let indRecrs := ((← read).constMap.childrenOfWith ind.name
        fun c => match c with | .recInfo _ => true | _ => false).map (·.name)
      inds := inds ++ [indName]
      indCtors := indCtors ++ ind.ctors
      indRecs := indRecs ++ indRecrs
      nameData := nameData.insert indName (ind.ctors, indRecrs)
    | const => throw $ .invalidConstantKind const.name "inductive" const.ctorName

  -- `mutualConsts` is the list of the names of all constants associated with an
  -- inductive block: the inductives themselves, the constructors and the recursors
  let mutualConsts := inds ++ indCtors ++ indRecs

  let recrCtx := mutualConsts.enum.foldl (init := default)
    fun acc (i, n) => acc.insert n i

  -- This part will build the inductive block and add all inductives,
  -- constructors and recursors to `consts`
  let irInds ← initInd.all.mapM fun name => do match ← getLeanConstant name with
    | .inductInfo ind => withRecrs recrCtx do pure $ (← inductiveToIR ind)
    | const => throw $ .invalidConstantKind const.name "inductive" const.ctorName
  let blockHash ← commit $ .mutIndBlock irInds
  addBlockToEnv blockHash

  -- While iterating on the inductives from the mutual block, we need to track
  -- the correct objects to return
  let mut ret? : Option Lurk.F := none
  for (indIdx, indName) in initInd.all.enum do
    -- Store and cache inductive projections
    let name := indName
    let hash ← commit $ .inductiveProj ⟨blockHash, indIdx⟩
    addConstToEnv name hash
    if name == initInd.name then ret? := some hash

    let some (ctors, recrs) := nameData.find? indName
      | throw $ .cantFindMutDefIndex indName

    for (ctorIdx, ctorName) in ctors.enum do
      -- Store and cache constructor projections
      let hashes ← commit $ .constructorProj ⟨blockHash, indIdx, ctorIdx⟩
      addConstToEnv ctorName hashes

    for (recrIdx, recrName) in recrs.enum do
      -- Store and cache recursor projections
      let hashes ← commit $ .recursorProj ⟨blockHash, indIdx, recrIdx⟩
      addConstToEnv recrName hashes

  match ret? with
  | some ret => return ret
  | none => throw $ .constantNotContentAddressed initInd.name

partial def inductiveToIR (ind : Lean.InductiveVal) : ContAddrM Inductive := do
  let leanRecs := (← read).constMap.childrenOfWith ind.name
    fun c => match c with | .recInfo _ => true | _ => false
  let (recs, ctors) ← leanRecs.foldrM (init := ([], []))
    fun r (recs, ctors) => match r with
      | .recInfo rv =>
        if isInternalRec rv.type ind.name then do
          let (thisRec, thisCtors) := ← internalRecToIR ind.ctors r
          pure (thisRec :: recs, thisCtors)
        else do
          let thisRec ← externalRecToIR r
          pure (thisRec :: recs, ctors)
      | _ => throw $ .nonRecursorExtractedFromChildren r.name
  let (struct, unit) ← if ind.isRec || ind.numIndices != 0 then pure (false, false) else
    match ctors with
    -- Structures can only have one constructor
    | [ctor] => pure (true, ctor.fields == 0)
    | _ => pure (false, false)
  return ⟨ind.levelParams.length, ← contAddrExpr ind.type, ind.numParams, ind.numIndices,
    -- NOTE: for the purpose of extraction, the order of `ctors` and `recs` MUST
    -- match the order used in `recrCtx`
    ctors, recs, ind.isRec, ind.isReflexive, struct, unit⟩

partial def internalRecToIR (ctors : List Lean.Name) :
    Lean.ConstantInfo → ContAddrM (Recursor × List Constructor)
  | .recInfo rec => withLevels rec.levelParams do
    let typ ← contAddrExpr rec.type
    let (retCtors, retRules) ← rec.rules.foldrM (init := ([], []))
      fun r (retCtors, retRules) => do
        if ctors.contains r.ctor then
          let (ctor, rule) ← recRuleToIR r
          pure $ (ctor :: retCtors, rule :: retRules)
        else pure (retCtors, retRules) -- this is an external recursor rule
    let recr := ⟨rec.levelParams.length, typ, rec.numParams, rec.numIndices,
      rec.numMotives, rec.numMinors, retRules, rec.k, true⟩
    return (recr, retCtors)
  | const => throw $ .invalidConstantKind const.name "recursor" const.ctorName

partial def recRuleToIR (rule : Lean.RecursorRule) : ContAddrM $ Constructor × RecursorRule := do
  let rhs ← contAddrExpr rule.rhs
  match ← getLeanConstant rule.ctor with
  | .ctorInfo ctor => withLevels ctor.levelParams do
    let typ ← contAddrExpr ctor.type
    let ctor := ⟨ctor.levelParams.length, typ, ctor.cidx, ctor.numParams, ctor.numFields⟩
    pure (ctor, ⟨rule.nfields, rhs⟩)
  | const => throw $ .invalidConstantKind const.name "constructor" const.ctorName

partial def externalRecToIR : Lean.ConstantInfo → ContAddrM Recursor
  | .recInfo rec => withLevels rec.levelParams do
    let typ ← contAddrExpr rec.type
    let rules ← rec.rules.mapM externalRecRuleToIR
    return ⟨rec.levelParams.length, typ, rec.numParams, rec.numIndices,
      rec.numMotives, rec.numMinors, rules, rec.k, false⟩
  | const => throw $ .invalidConstantKind const.name "recursor" const.ctorName

partial def externalRecRuleToIR (rule : Lean.RecursorRule) : ContAddrM RecursorRule :=
  return ⟨rule.nfields, ← contAddrExpr rule.rhs⟩

/--
Content-addresses a Lean expression and adds it to the store.

Constants are the tricky case, for which there are two possibilities:
* The constant belongs to `recrCtx`, representing a recursive call. Those are
encoded as variables with indexes that go beyond the bind indexes
* The constant doesn't belong to `recrCtx`, meaning that it's not a recursion
and thus we can contAddr the actual constant right away
-/
partial def contAddrExpr : Lean.Expr → ContAddrM Expr
  | .mdata _ e => contAddrExpr e
  | expr => match expr with
    | .bvar idx => do match (← read).bindCtx.get? idx with
      -- Bound variables must be in the bind context
      | some _ => return .var idx []
      | none => throw $ .invalidBVarIndex idx
    | .sort lvl => return .sort $ ← contAddrUniv lvl
    | .const name lvls => do
      let univs ← lvls.mapM contAddrUniv
      match (← read).recrCtx.find? name with
      | some i => -- recursing!
        let idx := (← read).bindCtx.length + i
        return .var idx univs
      | none => return .const (← contAddrConst $ ← getLeanConstant name) univs
    | .app fnc arg => return .app (← contAddrExpr fnc) (← contAddrExpr arg)
    | .lam name typ bod _ =>
      return .lam (← contAddrExpr typ) (← withBinder name $ contAddrExpr bod)
    | .forallE name dom img _ =>
      return .pi (← contAddrExpr dom) (← withBinder name $ contAddrExpr img)
    | .letE name typ exp bod _ =>
      return .letE (← contAddrExpr typ) (← contAddrExpr exp)
        (← withBinder name $ contAddrExpr bod)
    | .lit lit => return .lit lit
    | .proj _ idx exp => return .proj idx (← contAddrExpr exp)
    | .fvar ..  => throw $ .freeVariableExpr expr
    | .mvar ..  => throw $ .metaVariableExpr expr
    | .mdata .. => throw $ .metaDataExpr expr

/--
A name-irrelevant ordering of Lean expressions.
`weakOrd` contains the best known current mutual ordering
-/
partial def cmpExpr (weakOrd : Std.RBMap Name Nat compare) :
    Lean.Expr → Lean.Expr → ContAddrM Ordering
  | e@(.mvar ..), _ => throw $ .unfilledExprMetavariable e
  | _, e@(.mvar ..) => throw $ .unfilledExprMetavariable e
  | e@(.fvar ..), _ => throw $ .freeVariableExpr e
  | _, e@(.fvar ..) => throw $ .freeVariableExpr e
  | .mdata _ x, .mdata _ y  => cmpExpr weakOrd x y
  | .mdata _ x, y  => cmpExpr weakOrd x y
  | x, .mdata _ y  => cmpExpr weakOrd x y
  | .bvar x, .bvar y => return (compare x y)
  | .bvar .., _ => return .lt
  | _, .bvar .. => return .gt
  | .sort x, .sort y => cmpLevel x y
  | .sort .., _ => return .lt
  | _, .sort .. => return .gt
  | .const x xls, .const y yls => do
    let univs ← concatOrds <$> (xls.zip yls).mapM fun (x,y) => cmpLevel x y
    if univs != .eq then return univs
    match weakOrd.find? x, weakOrd.find? y with
    | some nx, some ny => return compare nx ny
    | none, some _ => return .gt
    | some _, none => return .lt
    | none, none =>
      return compare (← contAddrConst $ ← getLeanConstant x)
        (← contAddrConst $ ← getLeanConstant y)
  | .const .., _ => return .lt
  | _, .const .. => return .gt
  | .app xf xa, .app yf ya =>
    (· * ·) <$> cmpExpr weakOrd xf yf <*> cmpExpr weakOrd xa ya
  | .app .., _ => return .lt
  | _, .app .. => return .gt
  | .lam _ xt xb _, .lam _ yt yb _ =>
    (· * ·) <$> cmpExpr weakOrd xt yt <*> cmpExpr weakOrd xb yb
  | .lam .., _ => return .lt
  | _, .lam .. => return .gt
  | .forallE _ xt xb _, .forallE _ yt yb _ =>
    (· * ·) <$> cmpExpr weakOrd xt yt <*> cmpExpr weakOrd xb yb
  | .forallE .., _ => return .lt
  | _, .forallE .. => return .gt
  | .letE _ xt xv xb _, .letE _ yt yv yb _ =>
    (· * · * ·) <$> cmpExpr weakOrd xt yt <*> cmpExpr weakOrd xv yv <*> cmpExpr weakOrd xb yb
  | .letE .., _ => return .lt
  | _, .letE .. => return .gt
  | .lit x, .lit y =>
    return if x < y then .lt else if x == y then .eq else .gt
  | .lit .., _ => return .lt
  | _, .lit .. => return .gt
  | .proj _ nx tx, .proj _ ny ty => do
    let ts ← cmpExpr weakOrd tx ty
    return concatOrds [compare nx ny, ts]

/-- AST comparison of two Lean definitions.
  `weakOrd` contains the best known current mutual ordering -/
partial def cmpDef (weakOrd : Std.RBMap Name Nat compare)
  (x : Lean.DefinitionVal) (y : Lean.DefinitionVal) :
    ContAddrM Ordering := do
  let ls := compare x.levelParams.length y.levelParams.length
  let ts ← cmpExpr weakOrd x.type y.type
  let vs ← cmpExpr weakOrd x.value y.value
  return concatOrds [ls, ts, vs]

/-- AST equality between two Lean definitions.
  `weakOrd` contains the best known current mutual ordering -/
@[inline] partial def eqDef (weakOrd : Std.RBMap Name Nat compare)
    (x y : Lean.DefinitionVal) : ContAddrM Bool :=
  return (← cmpDef weakOrd x y) == .eq

/--
`sortDefs` recursively sorts a list of mutual definitions into weakly equal blocks.
At each stage, we take as input the current best approximation of known weakly equal
blocks as a List of blocks, hence the `List (List DefinitionVal)` as the argument type.
We recursively take the input blocks and resort to improve the approximate known
weakly equal blocks, obtaining a sequence of list of blocks:
```
dss₀ := [startDefs]
dss₁ := sortDefs dss₀
dss₂ := sortDefs dss₁
dss₍ᵢ₊₁₎ := sortDefs dssᵢ ...
```
Initially, `startDefs` is simply the list of definitions we receive from `DefinitionVal.all`;
since there is no order yet, we treat it as one block all weakly equal. On the other hand,
at the end, there is some point where `dss₍ᵢ₊₁₎ := dssᵢ`, then we have hit a fixed point
and we may end the sorting process. (We claim that such a fixed point exists, although
technically we don't really have a proof.)

On each iteration, we hope to improve our knowledge of weakly equal blocks and use that
knowledge in the next iteration. e.g. We start with just one block with everything in it,
but the first sort may differentiate the one block into 3 blocks. Then in the second
iteration, we have more information than than first, since the relationship of the 3 blocks
gives us more information; this information may then be used to sort again, turning 3 blocks
into 4 blocks, and again 4 blocks into 6 blocks, etc, until we have hit a fixed point.
This step is done in the computation of `newDss` and then comparing it to the original `dss`.

Two optimizations:

1. `names := enum dss` records the ordering information in a map for faster access.
    Directly using `List.findIdx?` on dss is slow and introduces `Option` everywhere.
    `names` is used as a custom comparison in `ds.sortByM (cmpDef names)`.
2. `normDss/normNewDss`. We want to compare if two lists of blocks are equal.
    Technically blocks are sets and their order doesn't matter, but we have encoded
    them as lists. To fix this, we sort the list by name before comparing. Note we
    could maybe also use `List (RBTree ..)` everywhere, but it seemed like a hassle.
-/
partial def sortDefs (dss : List (List Lean.DefinitionVal)) :
    ContAddrM (List (List Lean.DefinitionVal)) := do
  let enum (ll : List (List Lean.DefinitionVal)) :=
    Std.RBMap.ofList (ll.enum.map fun (n, xs) => xs.map (·.name, n)).join
  let weakOrd := enum dss _
  let newDss ← (← dss.mapM fun ds =>
    match ds with
    | []  => unreachable!
    | [d] => pure [[d]]
    | ds  => do pure $ (← List.groupByM (eqDef weakOrd) $
      ← ds.sortByM (cmpDef weakOrd))).joinM

  -- must normalize, see comments
  let normDss    := dss.map    fun ds => ds.map (·.name) |>.sort
  let normNewDss := newDss.map fun ds => ds.map (·.name) |>.sort
  if normDss == normNewDss then return newDss
  else sortDefs newDss

end

/-- Iterates over a list of `Lean.ConstantInfo`, triggering their content-addressing -/
def contAddrM (delta : List Lean.ConstantInfo) : ContAddrM Unit := do
  delta.forM fun c => if !c.isUnsafe then discard $ contAddrConst c else pure ()
  if (← read).persist then dumpData (← get).ldonHashState LDONHASHCACHE

/--
Content-addresses the "delta" of an environment, that is, the content that is
added on top of the imports.

Important: constants with open references in their expressions are filtered out.
Open references are variables that point to names which aren't present in the
`Lean.ConstMap`.
-/
def contAddr (constMap : Lean.ConstMap) (delta : List Lean.ConstantInfo)
    (quick persist : Bool) : IO $ Except ContAddrError ContAddrState := do
  let persist := if quick then false else persist
  let ldonHashState ←
    if quick then pure default
    else pure $ (← loadData LDONHASHCACHE).getD default
  if persist then IO.FS.createDirAll STOREDIR
  match ← StateT.run (ReaderT.run (contAddrM delta)
    (.init constMap quick persist)) (.init ldonHashState) with
  | (.ok _, stt) => return .ok stt
  | (.error e, _) => return .error e

end Yatima.ContAddr


-- auxiliary lemmas about translation of environments/variable bindings

import .definitions3 .substitution

lemma free_of_contains {P: prop} {σ: env} {x: var}: (⊩ σ : P) → x ∈ σ → x ∈ FV P :=
  assume env_verified: ⊩ σ : P,
  assume x_contained: x ∈ σ,
  show x ∈ FV P, by begin
    induction env_verified,
    case env.dvcgen.empty {
      cases x_contained
    },
    case env.dvcgen.tru σ' y Q _ _ ih { from
      or.elim (env.contains.inv x_contained) (
        assume : x = y,
        have free_in_term x y, from this ▸ free_in_term.var x,
        have free_in_term x (y ≡ value.true), from free_in_term.binop₁ this,
        have free_in_prop x (y ≡ value.true), from free_in_prop.term this,
        show x ∈ FV (Q ⋀ y ≡ value.true), from free_in_prop.and₂ this
      ) (
        assume : x ∈ σ',
        have x ∈ FV Q, from ih this,
        show x ∈ FV (Q ⋀ y ≡ value.true), from free_in_prop.and₁ this
      )
    },
    case env.dvcgen.fls σ' y Q _ _ ih { from
      or.elim (env.contains.inv x_contained) (
        assume : x = y,
        have free_in_term x y, from this ▸ free_in_term.var x,
        have free_in_term x (y ≡ value.false), from free_in_term.binop₁ this,
        have free_in_prop x (y ≡ value.false), from free_in_prop.term this,
        show x ∈ FV (Q ⋀ y ≡ value.false), from free_in_prop.and₂ this
      ) (
        assume : x ∈ σ',
        have x ∈ FV Q, from ih this,
        show x ∈ FV (Q ⋀ y ≡ value.false), from free_in_prop.and₁ this
      )
    },
    case env.dvcgen.num n σ' y Q _ _ ih { from
      or.elim (env.contains.inv x_contained) (
        assume : x = y,
        have free_in_term x y, from this ▸ free_in_term.var x,
        have free_in_term x (y ≡ value.num n), from free_in_term.binop₁ this,
        have free_in_prop x (y ≡ value.num n), from free_in_prop.term this,
        show x ∈ FV (Q ⋀ y ≡ value.num n), from free_in_prop.and₂ this
      ) (
        assume : x ∈ σ',
        have x ∈ FV Q, from ih this,
        show x ∈ FV (Q ⋀ y ≡ value.num n), from free_in_prop.and₁ this
      )
    },
    case env.dvcgen.func f σ₂ σ₁ g gx R S e Q₁ Q₂ Q₃ _ _ _ _ _ _ _ fv_R fv_S e_verified _ ih₁ ih₂ { from
      or.elim (env.contains.inv x_contained) (
        assume : x = f,
        have free_in_term x f, from this ▸ free_in_term.var x,
        have free_in_term x (f ≡ value.func g gx R S e σ₂), from free_in_term.binop₁ this,
        have free_in_prop x (f ≡ value.func g gx R S e σ₂), from free_in_prop.term this,
        have x ∈ FV (prop.term (f ≡ value.func g gx R S e σ₂) ⋀
                     prop.subst_env (σ₂[g↦value.func g gx R S e σ₂])
                     (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))), from free_in_prop.and₁ this,
        show x ∈ FV (Q₁ ⋀ f ≡ value.func g gx R S e σ₂ ⋀
                     prop.subst_env (σ₂[g↦value.func g gx R S e σ₂])
                     (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))), from free_in_prop.and₂ this
      ) (
        assume : x ∈ σ₁,
        have x ∈ FV Q₁, from ih₁ this,
        show x ∈ FV (Q₁ ⋀ f ≡ value.func g gx R S e σ₂ ⋀
                     prop.subst_env (σ₂[g↦value.func g gx R S e σ₂])
                     (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))), from free_in_prop.and₁ this
      )
    }
  end

lemma exp.post_free {P: prop} {e: exp} {Q: propctx} {x: var}:
       (P ⊩ e : Q) → ∀t, x ∈ FV (Q t) → x ∈ FV t ∨ x ∈ FV P :=
  assume e_verified: P ⊩ e : Q,
  begin
    induction e_verified,
    case exp.dvcgen.tru P y e' Q y_not_in_P e'_verified ih { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.exis y ((y ≡ value.true) ⋀ Q)) t),
      have x_neq_y: x ≠ y, from (free_in_propctx.exis.inv x_free_in_Qt).left,
      have x_not_in_yv: x ∉ FV (y ≡ value.true), from (
        assume : x ∈ FV (y ≡ value.true),
        have free_in_term x y ∨ free_in_term x value.true, from free_in_term.binop.inv this,
        or.elim this (
          assume : free_in_term x y,
          have x = y, from free_in_term.var.inv this,
          show «false», from x_neq_y this
        ) (
          assume : free_in_term x value.true,
          show «false», from free_in_term.value.inv this
        )
      ),
      have x ∈ FV ((↑(y ≡ value.true) ⋀ Q) t), from (free_in_propctx.exis.inv x_free_in_Qt).right,
      have x ∈ FV (propctx.term (y ≡ value.true) t) ∨ x ∈ FV (Q t), from free_in_propctx.and.inv this,
      or.elim this (
        assume : x ∈ FV (propctx.term (y ≡ value.true) t),
        have x ∈ FV (((y ≡ value.true).to_termctx) t), from free_in_propctx.term.inv this,
        have x ∈ FV (y ≡ value.true), from free_in_termctx.term.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from absurd this x_not_in_yv
      ) (
        assume : x ∈ FV (Q t),
        have x ∈ FV t ∨ x ∈ FV (P ⋀ (y ≡ value.true)), from ih t this,
        or.elim this (
          assume : x ∈ FV t,
          show x ∈ FV t ∨ x ∈ FV P, from or.inl this
        ) (
          assume : x ∈ FV (P ⋀ (y ≡ value.true)),
          or.elim (free_in_prop.and.inv this) (
            assume : x ∈ FV P,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr this
          ) (
            assume : x ∈ FV (prop.term (y ≡ value.true)),
            have x ∈ FV (y ≡ value.true), from free_in_prop.term.inv this,
            show x ∈ FV t ∨ x ∈ FV P, from absurd this x_not_in_yv
          )
        )
      )
    },
    case exp.dvcgen.fals P y e' Q y_not_in_P e'_verified ih { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.exis y ((y ≡ value.false) ⋀ Q)) t),
      have x_neq_y: x ≠ y, from (free_in_propctx.exis.inv x_free_in_Qt).left,
      have x_not_in_yv: x ∉ FV (y ≡ value.false), from (
        assume : x ∈ FV (y ≡ value.false),
        have free_in_term x y ∨ free_in_term x value.false, from free_in_term.binop.inv this,
        or.elim this (
          assume : free_in_term x y,
          have x = y, from free_in_term.var.inv this,
          show «false», from x_neq_y this
        ) (
          assume : free_in_term x value.false,
          show «false», from free_in_term.value.inv this
        )
      ),
      have x ∈ FV ((↑(y ≡ value.false) ⋀ Q) t), from (free_in_propctx.exis.inv x_free_in_Qt).right,
      have x ∈ FV (propctx.term (y ≡ value.false) t) ∨ x ∈ FV (Q t), from free_in_propctx.and.inv this,
      or.elim this (
        assume : x ∈ FV (propctx.term (y ≡ value.false) t),
        have x ∈ FV (((y ≡ value.false).to_termctx) t), from free_in_propctx.term.inv this,
        have x ∈ FV (y ≡ value.false), from free_in_termctx.term.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from absurd this x_not_in_yv
      ) (
        assume : x ∈ FV (Q t),
        have x ∈ FV t ∨ x ∈ FV (P ⋀ (y ≡ value.false)), from ih t this,
        or.elim this (
          assume : x ∈ FV t,
          show x ∈ FV t ∨ x ∈ FV P, from or.inl this
        ) (
          assume : x ∈ FV (P ⋀ (y ≡ value.false)),
          or.elim (free_in_prop.and.inv this) (
            assume : x ∈ FV P,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr this
          ) (
            assume : x ∈ FV (prop.term (y ≡ value.false)),
            have x ∈ FV (y ≡ value.false), from free_in_prop.term.inv this,
            show x ∈ FV t ∨ x ∈ FV P, from absurd this x_not_in_yv
          )
        )
      )
    },
    case exp.dvcgen.num P y n e' Q y_not_in_P e'_verified ih { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.exis y ((y ≡ value.num n) ⋀ Q)) t),
      have x_neq_y: x ≠ y, from (free_in_propctx.exis.inv x_free_in_Qt).left,
      have x_not_in_yv: x ∉ FV (y ≡ value.num n), from (
        assume : x ∈ FV (y ≡ value.num n),
        have free_in_term x y ∨ free_in_term x (value.num n), from free_in_term.binop.inv this,
        or.elim this (
          assume : free_in_term x y,
          have x = y, from free_in_term.var.inv this,
          show «false», from x_neq_y this
        ) (
          assume : free_in_term x (value.num n),
          show «false», from free_in_term.value.inv this
        )
      ),
      have x ∈ FV ((↑(y ≡ value.num n) ⋀ Q) t), from (free_in_propctx.exis.inv x_free_in_Qt).right,
      have x ∈ FV (propctx.term (y ≡ value.num n) t) ∨ x ∈ FV (Q t), from free_in_propctx.and.inv this,
      or.elim this (
        assume : x ∈ FV (propctx.term (y ≡ value.num n) t),
        have x ∈ FV (((y ≡ value.num n).to_termctx) t), from free_in_propctx.term.inv this,
        have x ∈ FV (y ≡ value.num n), from free_in_termctx.term.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from absurd this x_not_in_yv
      ) (
        assume : x ∈ FV (Q t),
        have x ∈ FV t ∨ x ∈ FV (P ⋀ (y ≡ value.num n)), from ih t this,
        or.elim this (
          assume : x ∈ FV t,
          show x ∈ FV t ∨ x ∈ FV P, from or.inl this
        ) (
          assume : x ∈ FV (P ⋀ (y ≡ value.num n)),
          or.elim (free_in_prop.and.inv this) (
            assume : x ∈ FV P,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr this
          ) (
            assume : x ∈ FV (prop.term (y ≡ value.num n)),
            have x ∈ FV (y ≡ value.num n), from free_in_prop.term.inv this,
            show x ∈ FV t ∨ x ∈ FV P, from absurd this x_not_in_yv
          )
        )
      )
    },
    case exp.dvcgen.func P f fx R S e₁ e₂ Q₁ Q₂ f_not_in_P _ _ _ fv_R fv_S _ _ func_vc ih₁ ih₂ { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.exis f ((prop.func f fx R (Q₁ (term.app f fx) ⋀ S)) ⋀ Q₂)) t),
      have x_neq_f: x ≠ f, from (free_in_propctx.exis.inv x_free_in_Qt).left,
      have x_not_in_non_rec_func: x ∈ FV (prop.func f fx R S) → x ∈ FV P, from (
        assume : x ∈ FV (prop.func f fx R S),
        have x ∈ FV (term.var f) ∨ (x ≠ fx ∧ (x ∈ FV R.to_prop ∨ x ∈ FV S.to_prop)),
        from free_in_prop.func.inv this,
        or.elim this (
          assume : x ∈ FV (term.var f),
          have x = f, from free_in_term.var.inv this,
          show x ∈ FV P, from absurd this x_neq_f
        ) (
          assume : x ≠ fx ∧ (x ∈ FV R.to_prop ∨ x ∈ FV S.to_prop),
          have x_neq_fx: x ≠ fx, from this.left,
          or.elim this.right (
            assume : x ∈ FV R.to_prop,
            have x ∈ FV P ∪ {f, fx}, from set.mem_of_mem_of_subset this fv_R,
            have x ∈ FV P ∨ x ∈ {f, fx}, from set.mem_or_mem_of_mem_union this,
            or.elim this id (
              assume : x ∈ {f, fx},
              have (x = f) ∨ (x = fx), from set.two_elems_mem this,
              or.elim this (
                assume : x = f,
                show x ∈ FV P, from absurd this x_neq_f
              ) (
                assume : x = fx,
                show x ∈ FV P, from absurd this x_neq_fx
              )
            )
          ) (
            assume : x ∈ FV S.to_prop,
            have x ∈ FV P ∪ {f, fx}, from set.mem_of_mem_of_subset this fv_S,
            have x ∈ FV P ∨ x ∈ {f, fx}, from set.mem_or_mem_of_mem_union this,
            or.elim this id (
              assume : x ∈ {f, fx},
              have (x = f) ∨ (x = fx), from set.two_elems_mem this,
              or.elim this (
                assume : x = f,
                show x ∈ FV P, from absurd this x_neq_f
              ) (
                assume : x = fx,
                show x ∈ FV P, from absurd this x_neq_fx
              )
            )
          )
        )
      ),
      have x_not_in_func: x ∈ FV (prop.func f fx R (Q₁ (term.app f fx) ⋀ S)) → x ∈ FV P, from (
        assume : x ∈ FV (prop.func f fx R (Q₁ (term.app f fx) ⋀ S)),
        have x ∈ FV (term.var f) ∨ (x ≠ fx ∧ (x ∈ FV R.to_prop ∨ x ∈ FV (Q₁ (term.app f fx) ⋀ S))),
        from free_in_prop.func.inv this,
        or.elim this (
          assume : x ∈ FV (term.var f),
          have x = f, from free_in_term.var.inv this,
          show x ∈ FV P, from absurd this x_neq_f
        ) (
          assume : x ≠ fx ∧ (x ∈ FV R.to_prop ∨ x ∈ FV (Q₁ (term.app f fx) ⋀ S)),
          have x_neq_fx: x ≠ fx, from this.left,
          have x_not_in_R: x ∈ FV R.to_prop → x ∈ FV P, from (
            assume : x ∈ FV R.to_prop,
            have x ∈ FV P ∪ {f, fx}, from set.mem_of_mem_of_subset this fv_R,
            have x ∈ FV P ∨ x ∈ {f, fx}, from set.mem_or_mem_of_mem_union this,
            or.elim this id (
              assume : x ∈ {f, fx},
              have (x = f) ∨ (x = fx), from set.two_elems_mem this,
              or.elim this (
                assume : x = f,
                show x ∈ FV P, from absurd this x_neq_f
              ) (
                assume : x = fx,
                show x ∈ FV P, from absurd this x_neq_fx
              )
            )
          ),
          have x_not_in_S: x ∈ FV S.to_prop → x ∈ FV P, from (
            assume : x ∈ FV S.to_prop,
            have x ∈ FV P ∪ {f, fx}, from set.mem_of_mem_of_subset this fv_S,
            have x ∈ FV P ∨ x ∈ {f, fx}, from set.mem_or_mem_of_mem_union this,
            or.elim this id (
              assume : x ∈ {f, fx},
              have (x = f) ∨ (x = fx), from set.two_elems_mem this,
              or.elim this (
                assume : x = f,
                show x ∈ FV P, from absurd this x_neq_f
              ) (
                assume : x = fx,
                show x ∈ FV P, from absurd this x_neq_fx
              )
            )
          ),
          or.elim this.right x_not_in_R (
            assume : x ∈ FV (Q₁ (term.app f fx) ⋀ S),
            or.elim (free_in_prop.and.inv this) (
              assume : x ∈ FV (Q₁ (term.app f fx)),
              have x ∈ FV (term.app f fx) ∨ x ∈ FV (P ⋀ (spec.func f fx R S) ⋀ R), from ih₁ (term.app f fx) this,
              or.elim this (
                assume : x ∈ FV (term.app f fx),
                have free_in_term x f ∨ free_in_term x fx, from free_in_term.app.inv this,
                or.elim this (
                  assume : free_in_term x f,
                  have x = f, from free_in_term.var.inv this,
                  show x ∈ FV P, from absurd this x_neq_f
                ) (
                  assume : free_in_term x fx,
                  have x = fx, from free_in_term.var.inv this,
                  show x ∈ FV P, from absurd this x_neq_fx
                )
              ) (
                assume : x ∈ FV (P ⋀ (spec.func f fx R S) ⋀ R),
                or.elim (free_in_prop.and.inv this) id (
                  assume : free_in_prop x (spec.func f fx R S ⋀ R),
                  have h: free_in_prop x ((spec.func f fx R S).to_prop ⋀ R.to_prop), from this,
                  have spec.to_prop (spec.func f fx R S) = prop.func f fx R.to_prop S.to_prop, by unfold spec.to_prop,
                  have free_in_prop x (prop.func f fx R S ⋀ R.to_prop), from this ▸ h,
                  or.elim (free_in_prop.and.inv this).symm x_not_in_R (
                    assume : x ∈ FV (prop.func f fx R S),
                    show x ∈ FV P, from x_not_in_non_rec_func this
                  )
                )
              )
            ) (
              assume : x ∈ FV S.to_prop,
              have x ∈ FV P ∪ {f, fx}, from set.mem_of_mem_of_subset this fv_S,
              have x ∈ FV P ∨ x ∈ {f, fx}, from set.mem_or_mem_of_mem_union this,
              or.elim this id (
                assume : x ∈ {f, fx},
                have (x = f) ∨ (x = fx), from set.two_elems_mem this,
                or.elim this (
                  assume : x = f,
                  show x ∈ FV P, from absurd this x_neq_f
                ) (
                  assume : x = fx,
                  show x ∈ FV P, from absurd this x_neq_fx
                )
              )
            )
          )
        )
      ),
      have x ∈ FV ((propctx.and (prop.func f fx R (Q₁ (term.app f fx) ⋀ S)) Q₂) t),
      from (free_in_propctx.exis.inv x_free_in_Qt).right,
      have x ∈ FV ((prop.func f fx R (Q₁ (term.app f fx) ⋀ S)) t) ∨ x ∈ FV (Q₂ t),
      from free_in_propctx.and.inv this,
      or.elim this (
        assume : x ∈ FV ((prop.func f fx R (Q₁ (term.app f fx) ⋀ S)) t),
        have x ∈ FV (prop.func f fx R (Q₁ (term.app f fx) ⋀ S)), from free_in_propctx.prop.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_func this)
      ) (
        assume : x ∈ FV (Q₂ t),
        have x ∈ FV t ∨ x ∈ FV (P ⋀ prop.func f fx R (Q₁ (term.app f fx) ⋀ S)), from ih₂ t this,
        or.elim this (
          assume : x ∈ FV t,
          show x ∈ FV t ∨ x ∈ FV P, from or.inl this
        ) (
          assume : x ∈ FV (P ⋀ prop.func f fx R (Q₁ (term.app f fx) ⋀ S)),
          or.elim (free_in_prop.and.inv this) (
            assume : x ∈ FV P,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr this
          ) (
            assume : x ∈ FV (prop.func f fx R (Q₁ (term.app f fx) ⋀ S)),
            show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_func this)
          )
        )
      )
    },
    case exp.dvcgen.unop op P e' x₁ y Q x_free_in_P y_not_in_P e'_verified vc_valid ih { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.exis y ((y ≡ term.unop op x₁) ⋀ Q)) t),
      have x_neq_y: x ≠ y, from (free_in_propctx.exis.inv x_free_in_Qt).left,
      have x_not_in_unop: x ∈ FV (y ≡ term.unop op x₁) → x ∈ FV P, from (
        assume : x ∈ FV (y ≡ term.unop op x₁),
        have free_in_term x y ∨ free_in_term x (term.unop op x₁), from free_in_term.binop.inv this,
        or.elim this (
          assume : free_in_term x y,
          have x = y, from free_in_term.var.inv this,
          show x ∈ FV P, from absurd this x_neq_y
        ) (
          assume : free_in_term x (term.unop op x₁),
          have free_in_term x x₁, from free_in_term.unop.inv this,
          have x = x₁, from free_in_term.var.inv this,
          show x ∈ FV P, from this.symm ▸ x_free_in_P
        )
      ),
      have x ∈ FV ((↑(y ≡ term.unop op x₁) ⋀ Q) t), from (free_in_propctx.exis.inv x_free_in_Qt).right,
      have x ∈ FV (propctx.term (y ≡ term.unop op x₁) t) ∨ x ∈ FV (Q t), from free_in_propctx.and.inv this,
      or.elim this (
        assume : x ∈ FV (propctx.term (y ≡ term.unop op x₁) t),
        have x ∈ FV (((y ≡ term.unop op x₁).to_termctx) t), from free_in_propctx.term.inv this,
        have x ∈ FV (y ≡ term.unop op x₁), from free_in_termctx.term.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_unop this)
      ) (
        assume : x ∈ FV (Q t),
        have x ∈ FV t ∨ x ∈ FV (P ⋀ (y ≡ term.unop op x₁)), from ih t this,
        or.elim this (
          assume : x ∈ FV t,
          show x ∈ FV t ∨ x ∈ FV P, from or.inl this
        ) (
          assume : x ∈ FV (P ⋀ (y ≡ term.unop op x₁)),
          or.elim (free_in_prop.and.inv this) (
            assume : x ∈ FV P,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr this
          ) (
            assume : x ∈ FV (prop.term (y ≡ term.unop op x₁)),
            have x ∈ FV (y ≡ term.unop op x₁), from free_in_prop.term.inv this,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_unop this)
          )
        )
      )
    },
    case exp.dvcgen.binop op P e' x₁ x₂ y Q x₁_free_in_P x₂_free_in_P y_not_in_P e'_verified vc_valid ih { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.exis y ((y ≡ term.binop op x₁ x₂) ⋀ Q)) t),
      have x_neq_y: x ≠ y, from (free_in_propctx.exis.inv x_free_in_Qt).left,
      have x_not_in_binop: x ∈ FV (y ≡ term.binop op x₁ x₂) → x ∈ FV P, from (
        assume : x ∈ FV (y ≡ term.binop op x₁ x₂),
        have free_in_term x y ∨ free_in_term x (term.binop op x₁ x₂), from free_in_term.binop.inv this,
        or.elim this (
          assume : free_in_term x y,
          have x = y, from free_in_term.var.inv this,
          show x ∈ FV P, from absurd this x_neq_y
        ) (
          assume : free_in_term x (term.binop op x₁ x₂),
          have free_in_term x x₁ ∨ free_in_term x x₂, from free_in_term.binop.inv this,
          or.elim this (
            assume : free_in_term x x₁,
            have x = x₁, from free_in_term.var.inv this,
            show x ∈ FV P, from this.symm ▸ x₁_free_in_P
          ) (
            assume : free_in_term x x₂,
            have x = x₂, from free_in_term.var.inv this,
            show x ∈ FV P, from this.symm ▸ x₂_free_in_P
          )
        )
      ),
      have x ∈ FV ((↑(y ≡ term.binop op x₁ x₂) ⋀ Q) t), from (free_in_propctx.exis.inv x_free_in_Qt).right,
      have x ∈ FV (propctx.term (y ≡ term.binop op x₁ x₂) t) ∨ x ∈ FV (Q t), from free_in_propctx.and.inv this,
      or.elim this (
        assume : x ∈ FV (propctx.term (y ≡ term.binop op x₁ x₂) t),
        have x ∈ FV (((y ≡ term.binop op x₁ x₂).to_termctx) t), from free_in_propctx.term.inv this,
        have x ∈ FV (y ≡ term.binop op x₁ x₂), from free_in_termctx.term.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_binop this)
      ) (
        assume : x ∈ FV (Q t),
        have x ∈ FV t ∨ x ∈ FV (P ⋀ (y ≡ term.binop op x₁ x₂)), from ih t this,
        or.elim this (
          assume : x ∈ FV t,
          show x ∈ FV t ∨ x ∈ FV P, from or.inl this
        ) (
          assume : x ∈ FV (P ⋀ (y ≡ term.binop op x₁ x₂)),
          or.elim (free_in_prop.and.inv this) (
            assume : x ∈ FV P,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr this
          ) (
            assume : x ∈ FV (prop.term (y ≡ term.binop op x₁ x₂)),
            have x ∈ FV (y ≡ term.binop op x₁ x₂), from free_in_prop.term.inv this,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_binop this)
          )
        )
      )
    },
    case exp.dvcgen.app P y f e' x₁ Q f_free_in_P x₁_free_in_P y_not_in_P e'_verified vc_valid ih { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.exis y ((prop.call x₁) ⋀
                                                    (prop.post f x₁) ⋀
                                                    (y ≡ term.app f x₁) ⋀
                                                     Q)) t),
      have x_neq_y: x ≠ y, from (free_in_propctx.exis.inv x_free_in_Qt).left,
      have x_not_in_call: x ∈ FV (prop.call x₁) → x ∈ FV P, from (
        assume : x ∈ FV (prop.call x₁),
        have free_in_term x x₁, from free_in_prop.call.inv this,
        have x = x₁, from free_in_term.var.inv this,
        show x ∈ FV P, from this.symm ▸ x₁_free_in_P
      ),
      have x_not_in_post: x ∈ FV (prop.post f x₁) → x ∈ FV P, from (
        assume : x ∈ FV (prop.post f x₁),
        or.elim (free_in_prop.post.inv this) (
          assume : free_in_term x f,
          have x = f, from free_in_term.var.inv this,
          show x ∈ FV P, from this.symm ▸ f_free_in_P
        ) (
          assume : free_in_term x x₁,
          have x = x₁, from free_in_term.var.inv this,
          show x ∈ FV P, from this.symm ▸ x₁_free_in_P
        )
      ),
      have x_not_in_app: x ∈ FV (y ≡ term.app f x₁) → x ∈ FV P, from (
        assume : x ∈ FV (y ≡ term.app f x₁),
        have free_in_term x y ∨ free_in_term x (term.app f x₁), from free_in_term.binop.inv this,
        or.elim this (
          assume : free_in_term x y,
          have x = y, from free_in_term.var.inv this,
          show x ∈ FV P, from absurd this x_neq_y
        ) (
          assume : free_in_term x (term.app f x₁),
          have free_in_term x f ∨ free_in_term x x₁, from free_in_term.app.inv this,
          or.elim this (
            assume : free_in_term x f,
            have x = f, from free_in_term.var.inv this,
            show x ∈ FV P, from this.symm ▸ f_free_in_P
          ) (
            assume : free_in_term x x₁,
            have x = x₁, from free_in_term.var.inv this,
            show x ∈ FV P, from this.symm ▸ x₁_free_in_P
          )
        )
      ),
      have x ∈ FV ((↑(prop.call ↑x₁) ⋀ ↑(prop.post ↑f ↑x₁) ⋀ ↑(↑y ≡ term.app ↑f ↑x₁) ⋀ Q) t),
      from (free_in_propctx.exis.inv x_free_in_Qt).right,
      have x ∈ FV (((prop.call x₁):propctx) t) ∨ x ∈ FV ((↑(prop.post f x₁) ⋀ ↑(y ≡ term.app f x₁) ⋀ Q) t),
      from free_in_propctx.and.inv this,
      or.elim this (
        assume : x ∈ FV (((prop.call x₁):propctx) t),
        have x ∈ FV (prop.call x₁), from free_in_propctx.prop.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_call this)
      ) (
        assume : x ∈ FV ((↑(prop.post f x₁) ⋀ ↑(y ≡ term.app f x₁) ⋀ Q) t),
        have x ∈ FV (((prop.post f x₁):propctx) t) ∨ x ∈ FV ((↑(y ≡ term.app f x₁) ⋀ Q) t),
        from free_in_propctx.and.inv this,
        or.elim this (
          assume : x ∈ FV (((prop.post f x₁):propctx) t),
          have x ∈ FV (prop.post f x₁), from free_in_propctx.prop.inv this,
          show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_post this)
        ) (
          assume : x ∈ FV ((↑(y ≡ term.app f x₁) ⋀ Q) t),
          have x ∈ FV ((↑(y ≡ term.app f x₁):propctx) t) ∨ x ∈ FV (Q t),
          from free_in_propctx.and.inv this,
          or.elim this (
            assume : x ∈ FV (((y ≡ term.app f x₁):propctx) t),
            have x ∈ FV ((y ≡ term.app f x₁):prop), from free_in_propctx.prop.inv this,
            have x ∈ FV (y ≡ term.app f x₁), from free_in_prop.term.inv this,
            show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_app this)
          ) (
            assume : x ∈ FV (Q t),
            have x ∈ FV t ∨ x ∈ FV (P ⋀ prop.call x₁ ⋀ prop.post f x₁ ⋀ (y ≡ term.app f x₁)),
            from ih t this,
            or.elim this (
              assume : x ∈ FV t,
              show x ∈ FV t ∨ x ∈ FV P, from or.inl this
            ) (
              assume : x ∈ FV (P ⋀ prop.call x₁ ⋀ prop.post f x₁ ⋀ (y ≡ term.app f x₁)),
              or.elim (free_in_prop.and.inv this) (
                assume : x ∈ FV P,
                show x ∈ FV t ∨ x ∈ FV P, from or.inr this
              ) (
                assume : x ∈ FV (prop.call x₁ ⋀ prop.post f x₁ ⋀ (y ≡ term.app f x₁)),
                or.elim (free_in_prop.and.inv this) (
                  assume : x ∈ FV (prop.call x₁),
                  show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_call this)
                ) (
                  assume : x ∈ FV (prop.post f x₁ ⋀ (y ≡ term.app f x₁)),
                  or.elim (free_in_prop.and.inv this) (
                    assume : x ∈ FV (prop.post f x₁),
                    show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_post this)
                  ) (
                    assume : free_in_prop x (y ≡ term.app f x₁),
                    have x ∈ FV (y ≡ term.app f x₁), from free_in_prop.term.inv this,
                    show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_app this)
                  )
                )
              )
            )
          )
        )
      )
    },
    case exp.dvcgen.ite P e₁ e₂ y Q₁ Q₂ y_free_in_P _ _ vc_valid ih₁ ih₂ { from
      assume t: term,
      assume x_free_in_Qt: x ∈ FV ((propctx.implies y Q₁ ⋀ propctx.implies (prop.not y) Q₂) t),
      have x_not_in_y: free_in_prop x y → x ∈ FV P, from (
        assume : free_in_prop x y,
        have free_in_term x y, from free_in_prop.term.inv this,
        have x = y, from free_in_term.var.inv this,
        show x ∈ FV P, from this.symm ▸ y_free_in_P
      ),
      have x_not_in_yn: free_in_prop x (prop.not y) → x ∈ FV P, from (
        assume : free_in_prop x (prop.not y),
        have free_in_prop x y, from free_in_prop.not.inv this,
        have free_in_term x y, from free_in_prop.term.inv this,
        have x = y, from free_in_term.var.inv this,
        show x ∈ FV P, from this.symm ▸ y_free_in_P
      ),
      or.elim (free_in_propctx.and.inv x_free_in_Qt) (
        assume : x ∈ FV ((propctx.implies y Q₁) t),
        or.elim (free_in_propctx.implies.inv this) (
          assume : x ∈ FV ((prop.term y).to_propctx t),
          have x ∈ FV (prop.term y), from free_in_propctx.prop.inv this,
          show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_y this)
        ) (
          assume : x ∈ FV (Q₁ t),
          have x ∈ FV t ∨ x ∈ FV (P ⋀ y), from ih₁ t this,
          or.elim this (
            assume : x ∈ FV t,
            show x ∈ FV t ∨ x ∈ FV P, from or.inl this
          ) (
            assume : x ∈ FV (P ⋀ y),
            or.elim (free_in_prop.and.inv this) (
              assume : x ∈ FV P,
              show x ∈ FV t ∨ x ∈ FV P, from or.inr this
            ) (
              assume : free_in_prop x y,
              have x ∈ FV P, from x_not_in_y this,
              show x ∈ FV t ∨ x ∈ FV P, from or.inr this
            )
          )
        )
      ) (
        assume : x ∈ FV ((propctx.implies (prop.not y) Q₂) t),
        or.elim (free_in_propctx.implies.inv this) (
          assume : x ∈ FV ((prop.not y).to_propctx t),
          have x ∈ FV (prop.not y), from free_in_propctx.prop.inv this,
          show x ∈ FV t ∨ x ∈ FV P, from or.inr (x_not_in_yn this)
        ) (
          assume : x ∈ FV (Q₂ t),
          have x ∈ FV t ∨ x ∈ FV (P ⋀ (prop.not y)), from ih₂ t this,
          or.elim this (
            assume : x ∈ FV t,
            show x ∈ FV t ∨ x ∈ FV P, from or.inl this
          ) (
            assume : x ∈ FV (P ⋀ (prop.not y)),
            or.elim (free_in_prop.and.inv this) (
              assume : x ∈ FV P,
              show x ∈ FV t ∨ x ∈ FV P, from or.inr this
            ) (
              assume : free_in_prop x (prop.not y),
              have x ∈ FV P, from x_not_in_yn this,
              show x ∈ FV t ∨ x ∈ FV P, from or.inr this
            )
          )
        )
      )
    },
    case exp.dvcgen.return P y y_free_in_P { from
      assume t: term,
      assume : x ∈ FV ((propctx.term (y ≣ •)) t),
      have x ∈ FV ((y ≣ •) t), from free_in_propctx.term.inv this,
      or.elim (free_in_termctx.binop.inv this) (
        assume : x ∈ FV ((y:termctx) t),
        have free_in_term x y, from free_in_termctx.term.inv this,
        have x = y, from free_in_term.var.inv this,
        have x ∈ FV P, from this.symm ▸ y_free_in_P,
        show x ∈ FV t ∨ x ∈ FV P, from or.inr this
      ) (
        assume : x ∈ FV (• t),
        have x ∈ FV t, from free_in_termctx.hole.inv this,
        show x ∈ FV t ∨ x ∈ FV P, from or.inl this
      )
    }
  end

lemma contains_of_free {P: prop} {σ: env} {x: var}: (⊩ σ : P) → free_in_prop x P → x ∈ σ :=
  assume env_verified: ⊩ σ : P,
  assume x_free_in_P: free_in_prop x P,
  show x ∈ σ, by begin
    induction env_verified,
    case env.dvcgen.empty { from
      have free_in_term x value.true, from free_in_prop.term.inv x_free_in_P,
      show x ∈ env.empty, from absurd this free_in_term.value.inv
    },
    case env.dvcgen.tru σ' y Q _ _ ih {
      show x ∈ (σ'[y↦value.true]), from contains_of_free_eq_value x_free_in_P ih
    },
    case env.dvcgen.fls σ' y Q _ _ ih { from
      show x ∈ (σ'[y↦value.false]), from contains_of_free_eq_value x_free_in_P ih
    },
    case env.dvcgen.num n σ' y Q _ _ ih { from
      show x ∈ (σ'[y↦value.num n]), from contains_of_free_eq_value x_free_in_P ih
    },
    case env.dvcgen.func f σ₂ σ₁ g gx R S e Q₁ Q₂ Q₃ _ _ _ _ _ _ _ fv_R fv_S e_verified _ ih₁ ih₂ { from
      contains_of_free_in_nonempty_env (
        assume : f ≠ x,
        have x_neq_f: x ≠ f, from this.symm,
        let vf := value.func g gx R S e σ₂ in
        have free_in_prop x Q₁
           ∨ free_in_prop x ((f ≡ vf) ⋀ prop.subst_env (σ₂[g↦vf]) (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
        from free_in_prop.and.inv x_free_in_P,
        or.elim this (
          assume x_free_in_Q₁: free_in_prop x Q₁,
          show x ∈ σ₁, from ih₁ x_free_in_Q₁
        ) (
          assume : free_in_prop x ((f ≡ vf) ⋀ prop.subst_env (σ₂[g↦vf]) (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
          or.elim (free_in_prop.and.inv this) (
            assume x_free_in_eq_v: free_in_prop x (f ≡ vf),
            show x ∈ σ₁, by begin
              cases x_free_in_eq_v,
              case free_in_prop.term x_free_in_eq {
                cases x_free_in_eq,
                case free_in_term.binop₁ free_in_f {
                  have f_is_x: (f = x), from (free_in_term.var.inv free_in_f).symm,
                  contradiction
                },
                case free_in_term.binop₂ free_in_vf {
                  cases free_in_vf
                }
              }
            end
          ) (
            assume x_free_in_sFunc: free_in_prop x (prop.subst_env (σ₂[g↦vf]) (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
            have x ≠ g ∧ free_in_prop x (prop.subst_env σ₂ (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
            from free_of_subst_env_prop x_free_in_sFunc,
            have x_neq_g: x ≠ g, from this.left,
            have x_free_in_sFunc': free_in_prop x (prop.subst_env σ₂ (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))), from this.right,
            have x_free_in_func: free_in_prop x (prop.func g gx R (Q₃ (term.app g gx) ⋀ S)),
            from free_of_subst_env x_free_in_sFunc',
            let forallp := (prop.implies R.to_prop (prop.pre g gx)
                        ⋀ prop.implies (prop.post g gx) (Q₃ (term.app g gx) ⋀ S.to_prop)) in
            have h: prop.func g gx R.to_prop (Q₃ (term.app g gx) ⋀ S.to_prop)
                = (term.unop unop.isFunc g ⋀ prop.forallc gx forallp),
            by unfold prop.func,
            have free_in_prop x (term.unop unop.isFunc g ⋀ prop.forallc gx forallp), from h ▸ x_free_in_func,
            have free_in_prop x (term.unop unop.isFunc g) ∨ free_in_prop x (prop.forallc gx forallp),
            from free_in_prop.and.inv this,
            or.elim this (
              assume : free_in_prop x (term.unop unop.isFunc g),
              have free_in_term x (term.unop unop.isFunc g), from free_in_prop.term.inv this,
              have free_in_term x g, from free_in_term.unop.inv this,
              have x = g, from free_in_term.var.inv this,
              show x ∈ σ₁, from absurd this x_neq_g
            ) (
              assume x_free_in_forallp: free_in_prop x (prop.forallc gx forallp),
              have x_neq_gx: x ≠ gx, from (free_in_prop.forallc.inv x_free_in_forallp).left,

              have x_not_in_R: x ∉ FV R.to_prop, from (
                assume : free_in_prop x R.to_prop,
                have x ∈ FV Q₂ ∪ {g, gx}, from set.mem_of_mem_of_subset this fv_R,
                have x ∈ FV Q₂ ∨ x ∈ {g, gx}, from set.mem_or_mem_of_mem_union this,
                or.elim this (
                  assume : x ∈ FV Q₂,
                  have x ∈ σ₂, from ih₂ this,
                  have ¬ free_in_prop x (prop.subst_env σ₂ (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
                  from prop.not_free_of_subst_env this,
                  show «false», from this x_free_in_sFunc'
                ) (
                  assume : x ∈ {g, gx},
                  have (x = g) ∨ (x = gx), from set.two_elems_mem this,
                  or.elim this (
                    assume : x = g,
                    show «false», from x_neq_g this
                  ) (
                    assume : x = gx,
                    show «false», from x_neq_gx this
                  )
                )
              ),

              have x_not_in_S: x ∉ FV S.to_prop, from (
                assume : free_in_prop x S.to_prop,
                have x ∈ FV Q₂ ∪ {g, gx}, from set.mem_of_mem_of_subset this fv_S,
                have x ∈ FV Q₂ ∨ x ∈ {g, gx}, from set.mem_or_mem_of_mem_union this,
                or.elim this (
                  assume : x ∈ FV Q₂,
                  have x ∈ σ₂, from ih₂ this,
                  have ¬ free_in_prop x (prop.subst_env σ₂ (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
                  from prop.not_free_of_subst_env this,
                  show «false», from this x_free_in_sFunc'
                ) (
                  assume : x ∈ {g, gx},
                  have (x = g) ∨ (x = gx), from set.two_elems_mem this,
                  or.elim this (
                    assume : x = g,
                    show «false», from x_neq_g this
                  ) (
                    assume : x = gx,
                    show «false», from x_neq_gx this
                  )
                )
              ),

              have x_not_in_gfunc: x ∉ FV (prop.func g gx R S), from (
                assume x_free_in_gfunc: x ∈ FV (prop.func g gx R S),
                let forallp' := (prop.implies R.to_prop (prop.pre g gx)
                              ⋀ prop.implies (prop.post g gx) S.to_prop) in
                have h: prop.func g gx R.to_prop S.to_prop
                    = (term.unop unop.isFunc g ⋀ prop.forallc gx forallp'),
                by unfold prop.func,
                have free_in_prop x (term.unop unop.isFunc g ⋀ prop.forallc gx forallp'), from h ▸ x_free_in_gfunc,
                have free_in_prop x (term.unop unop.isFunc g) ∨ free_in_prop x (prop.forallc gx forallp'),
                from free_in_prop.and.inv this,
                or.elim this (
                  assume : free_in_prop x (term.unop unop.isFunc g),
                  have free_in_term x (term.unop unop.isFunc g), from free_in_prop.term.inv this,
                  have free_in_term x g, from free_in_term.unop.inv this,
                  have x = g, from free_in_term.var.inv this,
                  show «false», from x_neq_g this
                ) (
                  assume x_free_in_forallp': free_in_prop x (prop.forallc gx forallp'),
                  have x_neq_gx: x ≠ gx, from (free_in_prop.forallc.inv x_free_in_forallp').left,
                  have free_in_prop x forallp', from (free_in_prop.forallc.inv x_free_in_forallp').right,
                  or.elim (free_in_prop.and.inv this) (
                    assume : free_in_prop x (prop.implies R.to_prop (prop.pre g gx)),
                    or.elim (free_in_prop.implies.inv this) x_not_in_R (
                      assume : free_in_prop x (prop.pre g gx),
                      have free_in_term x g ∨ free_in_term x gx, from free_in_prop.pre.inv this,
                      or.elim this (
                        assume : free_in_term x g,
                        have x = g, from free_in_term.var.inv this,
                        show «false», from x_neq_g this
                      ) (
                        assume : free_in_term x gx,
                        have x = gx, from free_in_term.var.inv this,
                        show «false», from x_neq_gx this
                      )
                    )
                  ) (
                    assume : free_in_prop x (prop.implies (prop.post g gx) S.to_prop),
                    or.elim (free_in_prop.implies.inv this).symm x_not_in_S (
                      assume : free_in_prop x (prop.post g gx),
                      have free_in_term x g ∨ free_in_term x gx, from free_in_prop.post.inv this,
                      or.elim this (
                        assume : free_in_term x g,
                        have x = g, from free_in_term.var.inv this,
                        show «false», from x_neq_g this
                      ) (
                        assume : free_in_term x gx,
                        have x = gx, from free_in_term.var.inv this,
                        show «false», from x_neq_gx this
                      )
                    )
                  )
                )
              ),

              have free_in_prop x forallp, from (free_in_prop.forallc.inv x_free_in_forallp).right,
              or.elim (free_in_prop.and.inv this) (
                assume : free_in_prop x (prop.implies R.to_prop (prop.pre g gx)),
                or.elim (free_in_prop.implies.inv this) (
                  assume : x ∈ FV R.to_prop,
                  show x ∈ σ₁, from absurd this x_not_in_R
                ) (
                  assume : free_in_prop x (prop.pre g gx),
                  have free_in_term x g ∨ free_in_term x gx, from free_in_prop.pre.inv this,
                  or.elim this (
                    assume : free_in_term x g,
                    have x = g, from free_in_term.var.inv this,
                    show x ∈ σ₁, from absurd this x_neq_g
                  ) (
                    assume : free_in_term x gx,
                    have x = gx, from free_in_term.var.inv this,
                    show x ∈ σ₁, from absurd this x_neq_gx
                  )
                )
              ) (
                assume : free_in_prop x (prop.implies (prop.post g gx) (Q₃ (term.app g gx) ⋀ S.to_prop)),
                or.elim (free_in_prop.implies.inv this) (
                  assume : free_in_prop x (prop.post g gx),
                  have free_in_term x g ∨ free_in_term x gx, from free_in_prop.post.inv this,
                  or.elim this (
                    assume : free_in_term x g,
                    have x = g, from free_in_term.var.inv this,
                    show x ∈ σ₁, from absurd this x_neq_g
                  ) (
                    assume : free_in_term x gx,
                    have x = gx, from free_in_term.var.inv this,
                    show x ∈ σ₁, from absurd this x_neq_gx
                  )
                ) (
                  assume : free_in_prop x (Q₃ (term.app g gx) ⋀ S.to_prop),
                  have free_in_prop x (Q₃ (term.app g gx)) ∨ free_in_prop x S.to_prop, from free_in_prop.and.inv this,
                  or.elim this.symm (
                    assume : x ∈ FV S.to_prop,
                    show x ∈ σ₁, from absurd this x_not_in_S
                  ) (
                    assume : free_in_prop x (Q₃ (term.app g gx)),
                    have x ∈ FV (term.app g gx) ∨ x ∈ FV (Q₂ ⋀ (spec.func g gx R S) ⋀ R),
                    from exp.post_free e_verified (term.app g gx) this,
                    or.elim this (
                      assume : x ∈ FV (term.app g gx),
                      or.elim (free_in_term.app.inv this) (
                        assume : free_in_term x g,
                        have x = g, from free_in_term.var.inv this,
                        show x ∈ σ₁, from absurd this x_neq_g
                      ) (
                      assume : free_in_term x gx,
                      have x = gx, from free_in_term.var.inv this,
                      show x ∈ σ₁, from absurd this x_neq_gx
                      )
                    ) (
                      assume : x ∈ FV (Q₂ ⋀ (spec.func g gx R S) ⋀ R),
                      or.elim (free_in_prop.and.inv this) (
                        assume : x ∈ FV Q₂,
                        have x ∈ σ₂, from ih₂ this,
                        have ¬ free_in_prop x (prop.subst_env σ₂ (prop.func g gx R (Q₃ (term.app g gx) ⋀ S))),
                        from prop.not_free_of_subst_env this,
                        show x ∈ σ₁, from absurd x_free_in_sFunc' this
                      ) (

                        assume : free_in_prop x (spec.func g gx R S ⋀ R),
                        have h: free_in_prop x ((spec.func g gx R S).to_prop ⋀ R.to_prop), from this,
                        have spec.to_prop (spec.func g gx R S) = prop.func g gx R.to_prop S.to_prop,
                        by unfold spec.to_prop,
                        have free_in_prop x (prop.func g gx R S ⋀ R.to_prop), from this ▸ h,
                        or.elim (free_in_prop.and.inv this) (
                          assume : x ∈ FV (prop.func g gx R S),
                          show x ∈ σ₁, from absurd this x_not_in_gfunc
                        ) (
                          assume : x ∈ FV R.to_prop,
                          show x ∈ σ₁, from absurd this x_not_in_R
                        )
                      )
                    )
                  )
                )
              )
            )
          )
        )
      )
   }
 end

lemma prop_func_closed {P: prop} {Q: propctx} {σ: env} {f fx: var} {R S: spec} {e: exp}:
  (⊩ (σ[f↦value.func f fx R S e σ]) : (P
       ⋀ (f ≡ value.func f fx R S e σ)
       ⋀ prop.subst_env (σ[f↦value.func f fx R S e σ]) (prop.func f fx R (Q (term.app f fx) ⋀ S)))) →
  closed (prop.subst_env (σ[f↦value.func f fx R S e σ]) (prop.func f fx R (Q (term.app f fx) ⋀ S))) :=
  assume env_verified: ⊩ (σ[f↦value.func f fx R S e σ]) : (P
       ⋀ (f ≡ value.func f fx R S e σ)
       ⋀ prop.subst_env (σ[f↦value.func f fx R S e σ]) (prop.func f fx R (Q (term.app f fx) ⋀ S))),
  assume x: var,
  assume h: x ∈ FV (prop.subst_env (σ[f↦value.func f fx R S e σ]) (prop.func f fx R (Q (term.app f fx) ⋀ S))),
  have free_in_prop x (f ≡ value.func f fx R S e σ
       ⋀ prop.subst_env (σ[f↦value.func f fx R S e σ]) (prop.func f fx R (Q (term.app f fx) ⋀ S))),
  from free_in_prop.and₂ h,
  have x ∈ FV (P
       ⋀ (f ≡ value.func f fx R S e σ)
       ⋀ prop.subst_env (σ[f↦value.func f fx R S e σ]) (prop.func f fx R (Q (term.app f fx) ⋀ S))),
  from free_in_prop.and₂ this,
  have x ∈ (σ[f↦value.func f fx R S e σ]), from contains_of_free env_verified this,
  have x ∉ FV (prop.subst_env (σ[f↦value.func f fx R S e σ]) (prop.func f fx R (Q (term.app f fx) ⋀ S))),
  from prop.not_free_of_subst_env this,
  show «false», from this h

lemma free_iff_contains {P: prop} {σ: env}: (⊩ σ : P) → (σ.dom = FV P) :=
  assume σ_verified: ⊩ σ : P,
  set.eq_of_subset_of_subset (
    assume x: var,
    assume : x ∈ σ.dom,
    have x ∈ σ, from this,
    show x ∈ FV P, from free_of_contains σ_verified this
  ) (
    assume x: var,
    assume : x ∈ FV P,
    have x ∈ σ, from contains_of_free σ_verified this,
    show x ∈ σ.dom, from this
  )

lemma env_translation_closed_subst {P: prop} {σ: env}: (⊩ σ : P) → closed_subst σ P :=
  assume σ_verified: ⊩ σ : P,
  assume z: var,
  assume : z ∈ FV P,
  show z ∈ σ.dom, from (free_iff_contains σ_verified).symm ▸ this

lemma env.apply_of_vcgen {σ: env} {x: var} {v: value} {P: prop}:
      (⊩ (σ[x↦v]) : P) → ((σ[x↦v]) x = v) :=
  begin
    intro h1,
    have h2: (x ∉ σ), by begin
      cases h1,
      case env.dvcgen.tru P x_not_in_σ σ_verified {
        from x_not_in_σ
      },
      case env.dvcgen.fls P x_not_in_σ σ_verified {
        from x_not_in_σ
      },
      case env.dvcgen.num n P x_not_in_σ σ_verified {
        from x_not_in_σ
      },
      case env.dvcgen.func σ₃ f fx R S e Q₃ Q₄ Q₂ x_not_in_σ₂ f_not_in_σ₃ fx_not_in_σ₃
                          f_neq_fx σ₂_verified σ₃_verified x_free_in_R fv_R fv_S e_verified func_vc {
        from x_not_in_σ₂
      }
    end,
    from env.apply_of_contains h2
  end

lemma env.rest_verified {P: prop} {σ: env} {x: var} {v: value}:
      (⊩ (σ[x↦v]) : P) → ∃Q, ⊩ σ : Q :=
  assume σ_verified: ⊩ (σ[x↦v]) : P,
  begin
    cases σ_verified,
    case env.dvcgen.tru Q _ σ_verified {
      from exists.intro Q σ_verified
    },
    case env.dvcgen.fls Q _ σ_verified {
      from exists.intro Q σ_verified
    },
    case env.dvcgen.num n Q _ σ_verified {
      from exists.intro Q σ_verified
    },
    case env.dvcgen.func σ₂ f fx R S e Q Q₂ Q₃ x_not_in_σ f_not_in_σ₂
         fx_not_in_σ₂ f_neq_fx σ₁_verified {
      from exists.intro Q σ₁_verified
    }
  end

lemma env_free_rest {P: prop} {σ: env} {x: var} {v: value}:
      (⊩ (σ[x↦v]) : P) → (∃Q, (⊩ σ : Q) ∧ FV Q ⊆ FV P) :=
  assume σ_verified: ⊩ (σ[x↦v]) : P,
  begin
    cases σ_verified,
    case env.dvcgen.tru Q _ σ_verified ih { from
      have FV Q ⊆ FV (prop.and Q (x ≡ value.true)), from free_in_prop.and_left_subset,
      show ∃(Q_1 : prop), (⊩ σ : Q_1) ∧ FV Q_1 ⊆ FV (prop.and Q (x ≡ value.true)),
      from exists.intro Q ⟨σ_verified, this⟩
    },
    case env.dvcgen.fls Q _ σ_verified { from
      have FV Q ⊆ FV (prop.and Q (x ≡ value.false)), from free_in_prop.and_left_subset,
      show ∃(Q_1 : prop), (⊩ σ : Q_1) ∧ FV Q_1 ⊆ FV (prop.and Q (x ≡ value.false)),
      from exists.intro Q ⟨σ_verified, this⟩
    },
    case env.dvcgen.num n Q _ σ_verified { from
      have FV Q ⊆ FV (prop.and Q (x ≡ value.num n)), from free_in_prop.and_left_subset,
      show ∃(Q_1 : prop), (⊩ σ : Q_1) ∧ FV Q_1 ⊆ FV (prop.and Q (x ≡ value.num n)),
      from exists.intro Q ⟨σ_verified, this⟩
    },
    case env.dvcgen.func σ₂ f fx R S e Q Q₂ Q₃ x_not_in_σ f_not_in_σ₂
         fx_not_in_σ₂ f_neq_fx σ₁_verified σ₂_verified fx_in_R fv_R fv_S e_verified func_vc { from
      let funcp := prop.subst_env (σ₂[f↦value.func f fx R S e σ₂])
                                  (prop.func f fx R (Q₃ (term.app f fx) ⋀ S)) in
      have FV Q ⊆ FV (prop.and Q (x ≡ value.func f fx R S e σ₂ ⋀ funcp)), from free_in_prop.and_left_subset,
      show ∃(Q_1 : prop), (⊩ σ : Q_1) ∧ FV Q_1 ⊆ FV (prop.and Q (x ≡ value.func f fx R S e σ₂ ⋀ funcp)),
      from exists.intro Q ⟨σ₁_verified, this⟩
    }
  end


inductive Fam2 : Type → Type → Type 1 where
  | any : Fam2 α α
  | nat : Nat → Fam2 Nat Nat

set_option pp.rawOnError true
set_option trace.Elab.info true
example (a : α) (x : Fam2 α β) : β :=
  match x with
  | Fam2.any   => _
  | Fam2.nat n => n


/-
  Presheaf of rings extension.

  https://stacks.math.columbia.edu/tag/009N
-/

import to_mathlib.opens
import sheaves.covering.covering
import sheaves.presheaf_of_rings
import sheaves.presheaf_of_rings_on_basis
import sheaves.stalk_of_rings_on_standard_basis

universes u v w

open topological_space
open lattice
open covering
open stalk_of_rings_on_standard_basis.

section presheaf_of_rings_extension

variables {α : Type u} [topological_space α]
variables {B : set (opens α)} {HB : opens.is_basis B}
variables (Bstd : opens.univ ∈ B ∧ ∀ {U V}, U ∈ B → V ∈ B → U ∩ V ∈ B)

variables (F : presheaf_of_rings_on_basis α HB) (U : opens α)

include Bstd

section presheaf_of_rings_on_basis_extension_is_ring

@[reducible] def Fext :=
{ s : Π (x ∈ U), stalk_of_rings_on_standard_basis Bstd F x //
  ∀ (x ∈ U), ∃ (V) (BV : V ∈ B) (Hx : x ∈ V) (σ : F.to_presheaf_on_basis BV),
  ∀ (y ∈ U ∩ V), s y = λ _, ⟦{U := V, BU := BV, Hx := H.2, s := σ}⟧ }

-- Add.

private def Fext_add_aux (x : α)
: stalk_of_rings_on_standard_basis Bstd F x
→ stalk_of_rings_on_standard_basis Bstd F x
→ stalk_of_rings_on_standard_basis Bstd F x :=
(stalk_of_rings_on_standard_basis.has_add Bstd F x).add

private def Fext_add : Fext Bstd F U → Fext Bstd F U → Fext Bstd F U
:= λ ⟨s₁, Hs₁⟩ ⟨s₂, Hs₂⟩,
  ⟨λ x Hx, (Fext_add_aux Bstd F x) (s₁ x Hx) (s₂ x Hx),
  begin
    intros x Hx,
    replace Hs₁ := Hs₁ x Hx,
    replace Hs₂ := Hs₂ x Hx,
    rcases Hs₁ with ⟨V₁, BV₁, HxV₁, σ₁, Hs₁⟩,
    rcases Hs₂ with ⟨V₂, BV₂, HxV₂, σ₂, Hs₂⟩,
    use [V₁ ∩ V₂, Bstd.2 BV₁ BV₂, ⟨HxV₁, HxV₂⟩],
    let σ₁' := F.res BV₁ (Bstd.2 BV₁ BV₂) (set.inter_subset_left _ _) σ₁,
    let σ₂' := F.res BV₂ (Bstd.2 BV₁ BV₂) (set.inter_subset_right _ _) σ₂,
    use [σ₁' + σ₂'],
    rintros y ⟨HyU, ⟨HyV₁, HyV₂⟩⟩,
    apply funext,
    intros Hy,
    replace Hs₁ := Hs₁ y ⟨HyU, HyV₁⟩,
    replace Hs₂ := Hs₂ y ⟨HyU, HyV₂⟩,
    rw Hs₁,
    rw Hs₂,
    refl,
  end⟩

instance Fext_has_add : has_add (Fext Bstd F U) :=
{ add := Fext_add Bstd F U }

@[simp] lemma Fext_add.eq (x : α) (Hx : x ∈ U)
: ∀ (a b : Fext Bstd F U), (a + b).val x Hx = (a.val x Hx) + (b.val x Hx) :=
λ ⟨s₁, Hs₁⟩ ⟨s₂, Hs₂⟩, rfl

instance Fext_add_semigroup : add_semigroup (Fext Bstd F U) :=
{ add_assoc := λ a b c, subtype.eq $ funext $ λ x, funext $ λ HxU, by simp,
  ..Fext_has_add Bstd F U }

instance Fext_add_comm_semigroup : add_comm_semigroup (Fext Bstd F U) :=
{ add_comm := λ a b, subtype.eq $ funext $ λ x, funext $ λ HxU, by simp,
  ..Fext_add_semigroup Bstd F U }

-- Zero.

private def Fext_zero : Fext Bstd F U :=
⟨λ x Hx, (stalk_of_rings_on_standard_basis.has_zero Bstd F x).zero,
λ x Hx, ⟨opens.univ, Bstd.1, trivial, 0, (λ y Hy, funext $ λ HyU, rfl)⟩⟩

instance Fext_has_zero : has_zero (Fext Bstd F U) :=
{ zero := Fext_zero Bstd F U }

@[simp] lemma Fext_zero.eq (x : α) (Hx : x ∈ U)
: (0 : Fext Bstd F U).val x Hx = (stalk_of_rings_on_standard_basis.has_zero Bstd F x).zero := rfl

instance Fext_add_comm_monoid : add_comm_monoid (Fext Bstd F U) :=
{ zero_add := λ a, subtype.eq $ funext $ λ x, funext $ λ HxU, by simp,
  add_zero := λ a, subtype.eq $ funext $ λ x, funext $ λ HxU, by simp,
  ..Fext_has_zero Bstd F U,
  ..Fext_add_comm_semigroup Bstd F U, }

-- Neg.

private def Fext_neg_aux (x : α)
: stalk_of_rings_on_standard_basis Bstd F x
→ stalk_of_rings_on_standard_basis Bstd F x :=
(stalk_of_rings_on_standard_basis.has_neg Bstd F x).neg

private def Fext_neg : Fext Bstd F U → Fext Bstd F U :=
λ ⟨s, Hs⟩,
  ⟨λ x Hx, (Fext_neg_aux Bstd F x) (s x Hx),
  begin
    intros x Hx,
    replace Hs := Hs x Hx,
    rcases Hs with ⟨V, BV, HxV, σ, Hs⟩,
    use [V, BV, HxV, -σ],
    rintros y ⟨HyU, HyV⟩,
    apply funext,
    intros Hy,
    replace Hs := Hs y ⟨HyU, HyV⟩,
    rw Hs,
    refl,
  end⟩

instance Fext_has_neg : has_neg (Fext Bstd F U) :=
{ neg := Fext_neg Bstd F U, }

@[simp] lemma Fext_neg.eq (x : α) (Hx : x ∈ U)
: ∀ (a : Fext Bstd F U), (-a).val x Hx = -(a.val x Hx) :=
λ ⟨s, Hs⟩, rfl

instance Fext_add_comm_group : add_comm_group (Fext Bstd F U) :=
{ add_left_neg := λ a, subtype.eq $ funext $ λ x, funext $ λ HxU, by simp,
  ..Fext_has_neg Bstd F U,
  ..Fext_add_comm_monoid Bstd F U, }

-- Mul.

private def Fext_mul_aux (x : α)
: stalk_of_rings_on_standard_basis Bstd F x
→ stalk_of_rings_on_standard_basis Bstd F x
→ stalk_of_rings_on_standard_basis Bstd F x :=
(stalk_of_rings_on_standard_basis.has_mul Bstd F x).mul

private def Fext_mul : Fext Bstd F U → Fext Bstd F U → Fext Bstd F U
:= λ ⟨s₁, Hs₁⟩ ⟨s₂, Hs₂⟩,
  ⟨λ x Hx, (Fext_mul_aux Bstd F x) (s₁ x Hx) (s₂ x Hx),
  begin
    intros x Hx,
    replace Hs₁ := Hs₁ x Hx,
    replace Hs₂ := Hs₂ x Hx,
    rcases Hs₁ with ⟨V₁, BV₁, HxV₁, σ₁, Hs₁⟩,
    rcases Hs₂ with ⟨V₂, BV₂, HxV₂, σ₂, Hs₂⟩,
    use [V₁ ∩ V₂, Bstd.2 BV₁ BV₂, ⟨HxV₁, HxV₂⟩],
    let σ₁' := F.res BV₁ (Bstd.2 BV₁ BV₂) (set.inter_subset_left _ _) σ₁,
    let σ₂' := F.res BV₂ (Bstd.2 BV₁ BV₂) (set.inter_subset_right _ _) σ₂,
    use [σ₁' * σ₂'],
    rintros y ⟨HyU, ⟨HyV₁, HyV₂⟩⟩,
    apply funext,
    intros Hy,
    replace Hs₁ := Hs₁ y ⟨HyU, HyV₁⟩,
    replace Hs₂ := Hs₂ y ⟨HyU, HyV₂⟩,
    rw Hs₁,
    rw Hs₂,
    refl,
  end⟩

instance Fext_has_mul : has_mul (Fext Bstd F U) :=
{ mul := Fext_mul Bstd F U }

@[simp] lemma Fext_mul.eq (x : α) (Hx : x ∈ U)
: ∀ (a b : Fext Bstd F U), (a * b).val x Hx = (a.val x Hx) * (b.val x Hx) :=
λ ⟨s₁, Hs₁⟩ ⟨s₂, Hs₂⟩, rfl

instance Fext_mul_semigroup : semigroup (Fext Bstd F U) :=
{ mul_assoc := λ a b c, subtype.eq $ funext $ λ x, funext $ λ HxU,
  begin
    simp,
    apply (stalk_of_rings_on_standard_basis.mul_semigroup Bstd F x).mul_assoc,
  end,
  ..Fext_has_mul Bstd F U, }

instance Fext_mul_comm_semigroup : comm_semigroup (Fext Bstd F U) :=
{ mul_comm := λ a b, subtype.eq $ funext $ λ x, funext $ λ HxU,
    begin
      simp,
      apply (stalk_of_rings_on_standard_basis.mul_comm_semigroup Bstd F x).mul_comm,
    end,
  ..Fext_mul_semigroup Bstd F U, }

-- One.

private def Fext_one : Fext Bstd F U  :=
⟨λ x Hx, (stalk_of_rings_on_standard_basis.has_one Bstd F x).one,
λ x Hx, ⟨opens.univ, Bstd.1, trivial, 1, (λ y Hy, funext $ λ HyU, rfl)⟩⟩

instance Fext_has_one : has_one (Fext Bstd F U) :=
{ one := Fext_one Bstd F U }

instance Fext_mul_comm_monoid : comm_monoid (Fext Bstd F U) :=
{ one_mul := λ a, subtype.eq $ funext $ λ x, funext $ λ HxU,
    begin
      simp,
      apply (stalk_of_rings_on_standard_basis.mul_comm_monoid Bstd F x).one_mul,
    end,
  mul_one := λ a, subtype.eq $ funext $ λ x, funext $ λ HxU,
    begin
      simp,
      apply (stalk_of_rings_on_standard_basis.mul_comm_monoid Bstd F x).mul_one,
    end,
  ..Fext_has_one Bstd F U,
  ..Fext_mul_comm_semigroup Bstd F U, }

-- Ring

instance Fext_comm_ring : comm_ring (Fext Bstd F U) :=
{ left_distrib := λ a b c, subtype.eq $ funext $ λ x, funext $ λ HxU,
    begin
      rw Fext_add.eq,
      repeat { rw Fext_mul.eq, },
      rw Fext_add.eq,
      eapply (stalk_of_rings_on_standard_basis.comm_ring Bstd F x).left_distrib,
    end,
  right_distrib := λ a b c, subtype.eq $ funext $ λ x, funext $ λ HxU,
    begin
      rw Fext_add.eq,
      repeat { rw Fext_mul.eq, },
      rw Fext_add.eq,
      eapply (stalk_of_rings_on_standard_basis.comm_ring Bstd F x).right_distrib,
    end,
  ..Fext_add_comm_group Bstd F U,
  ..Fext_mul_comm_monoid Bstd F U, }

end presheaf_of_rings_on_basis_extension_is_ring

-- F defined in the whole space to F defined on the basis.

def presheaf_of_rings_to_presheaf_of_rings_on_basis
(F : presheaf_of_rings α) : presheaf_of_rings_on_basis α HB :=
{ F := λ U BU, F U,
  res := λ U V BU BV HVU, F.res U V HVU,
  Hid := λ U BU, F.Hid U,
  Hcomp := λ U V W BU BV BW, F.Hcomp U V W,
  Fring := λ U BU, F.Fring U,
  res_is_ring_hom := λ U V BU BV HVU, F.res_is_ring_hom U V HVU, }

-- F defined on the bases extended to the whole space.

def presheaf_of_rings_extension
(F : presheaf_of_rings_on_basis α HB) : presheaf_of_rings α :=
{ F := λ U, {s : Π (x ∈ U), stalk_on_basis F.to_presheaf_on_basis x //
        ∀ (x ∈ U), ∃ (V) (BV : V ∈ B) (Hx : x ∈ V) (σ : F.to_presheaf_on_basis BV),
        ∀ (y ∈ U ∩ V), s y = λ _, ⟦{U := V, BU := BV, Hx := H.2, s := σ}⟧},
  res := λ U W HWU FU,
        { val := λ x HxW, (FU.val x $ HWU HxW),
          property := λ x HxW,
            begin
              rcases (FU.property x (HWU HxW)) with ⟨V, ⟨BV, ⟨HxV, ⟨σ, HFV⟩⟩⟩⟩,
              use [V, BV, HxV, σ],
              rintros y ⟨HyW, HyV⟩,
              rw (HFV y ⟨HWU HyW, HyV⟩),
            end },
  Hid := λ U, funext $ λ x, subtype.eq rfl,
  Hcomp := λ U V W HWV HVU, funext $ λ x, subtype.eq rfl,
  Fring := λ U, Fext_comm_ring Bstd F U,
  res_is_ring_hom := λ U V HVU,
    { map_one := rfl,
      map_mul := λ x y, subtype.eq $ funext $ λ x, funext $ λ Hx,
        begin
          erw Fext_mul.eq,
          refl,
        end,
      map_add := λ x y, subtype.eq $ funext $ λ x, funext $ λ Hx,
        begin
          erw Fext_add.eq,
          refl,
        end, } }

notation F `ᵣₑₓₜ`:1 Bstd := presheaf_of_rings_extension Bstd F

end presheaf_of_rings_extension