import states observables
open set topological_space classical
local attribute [instance] prop_decidable
noncomputable theory

-- TODO: rename this file to essence.lean (maybe)
-- THIS FILE IS A WORK IN PROGRESS.

namespace ontology

variable {ω : ontology}

section relations

  variable (ω)

  -- abbreviation property (α := Prop) [topological_space α] [has_none α] := ω.observable α → ω.observable α
  abbreviation property (α : Type := Prop) [topological_space α] := ω.entity → ω.world → α

  def property.positive  {ω : ontology}{α : Type} [topological_space α] (p : ω.property α) : Prop := ∀ e, continuous (p e)

  abbreviation relation (α := Prop) [topological_space α] [has_none α] :=
    ω.observable α → ω.observable α → ω.observable α

  def {u} nary (α β : Type u) : ℕ → Type u
  | 0 := β
  | (n+1) := α → (nary n)

  def {u} tnary (β : Type u) : (list $ Type u) → Type u
  | [] := β
  | (hd::tl) := hd → (tnary tl)

  abbreviation nrelation (n : ℕ) (α := Prop) [topological_space α] [has_none α] :=
    nary (ω.observable α) (ω.observable α) n

  example : (ω.nrelation 2) = ω.relation := rfl

end relations

-- Next we must talk about predicates
section predicates

/-- A predicate is a function which outputs an event for an entity,
    i.e. the event of the entity having the predicate. -/
abbreviation predicate (ω : ontology) :=  ω.entity → ω.event

/-- An analogical predicate, or apredicate, outputs an aevent instead of an event.
    i.e the aevent of the entity having the predicate, which it can posses to a greater or lesser extent.
    This is analogy in the sense of **intrinsic attribution**.
    See thomistic manuals for a deeper informal discussion of intrinsic attribution.
   -/
abbreviation apredicate (ω : ontology) := ω.entity → ω.aevent

variable (p : ω.predicate)

-- Apparently Lean already infers correctly the proper notation for boolean algebra operations
-- (which is amazing), even though it does not elaborate the full boolean algebra instance.
-- we may consider defining this instance properly in the future, but for now, we just use the notation.
-- instance boolean_predicate : boolean_algebra ω.predicate := sorry

/-! Now, a predicate which, unlike an apredicate, does not return an aevent is in some sense univocal,
 but this univocity might occur in two different ways: in language alone, or both in language and in reality.
 The latter we call univocal predicates properly speaking, while the former we call *hidden* or *abstracted*
 analogical predicates. The difference between these two is that real univocal predicates preserve hierarchical
 distinctions in being, while abstracted, "fake", univocal predicates ignore such ontological distinctions.
 So essentially we say that a predicate is univocal in a possible world if and only if the entities which exemplify
 it in that world are incomparable with respect to existential entailment.
-/

-- TODO: change this definition to use existential entailment notation when it becomes available.
def predicate.lunivocal : ω.event :=
    { w |
      ∀ e₁ e₂, w ∈ p e₁ ∩ p e₂ → ¬ e₁.exists ⊂ e₂.exists ∧ ¬ e₁.exists ⊃ e₂.exists
    }
@[reducible]
def predicate.lhidden := -p.lunivocal
@[reducible]
def predicate.univocal := p.lunivocal.necessary
@[reducible]
def predicate.hidden := p.lhidden.necessary

/- The whole point of the Thomistic theory of the analogy of being consists
   in the realization that existence is a hidden analogy abstracted away from a deeper
   apredicate: Being.
-/
def existence (ω : ontology) : ω.predicate := entity.exists

-- In any possible world with at least 2 entities (hence at least one contingent entity)
-- existence is a hidden analogy.
theorem analogical_existence : ∀ w e₁ e₂, e₁ ≠ e₂ → e₁ ∈ w → e₂ ∈ w → w ∈ ω.existence.lhidden := sorry

instance predicate_inhabited : inhabited ω.predicate := ⟨ω.existence⟩

/-- a predicate `p` is **exemplifiable** if there is some `entity` which can possibly be `p`. -/
@[reducible]
def predicate.exemplifiable : Prop := ∃ e, ⋄(p e)

-- an entity is said to possibly exemplify a predicate if it does so in some possible world
@[reducible]
def entity.pexemplifies (e : ω.entity) := ⋄(p e)

-- a predicate is existential if an entity having the predicate implies its existence
@[reducible]
def predicate.existential := ∀ e, p e ⊆ e.exists

-- the common (sensical) predicates
structure predicate.common : Prop :=
    (axiom₀ : p.exemplifiable)
    (axiom₁ : p.existential)

-- A common predicate is positive if in any possible world in which an entity has the predicate,
-- there exists something in that world (e.g. an accident) to ground the predicate.
structure predicate.positive extends predicate.common p : Prop :=
    (axiom₂ : ∀ e, is_open (p e))

/-- A predicate is said to be ***de re* necessary** of an entity if the entity has that predicate in
    all and only the possible worlds in which it exists.
    Which is also to say that the entity is a *fixed point* of the predicate. -/
@[reducible]
def predicate.dere_of (e : ω.entity) := p e = e.exists
/-- Negation of `predicate.dere_of` -/
@[reducible]
def predicate.ndere_of (e : ω.entity) := p e ≠ e.exists

/-- A predicate is ***de re* necessary** in itself if it is *de re* necessary of all entities which may possibly
    exemplify it. -/
@[reducible]
def predicate.dere := ∀ e, ⋄(p e) → p.dere_of e
/-- A predicate is `adere` or **anti-*de re* necessary** if it fails to be *de re* necessary everywhere. -/
@[reducible]
def predicate.adere := ∀ e, ⋄(p e) → p.ndere_of e

/-- A positive predicate is possessed if it "talks about" its subject,
    which is to say that it is an accident or essential of a substance,
    or essential of an accident. -/
structure predicate.possessed extends predicate.positive p : Prop  :=
    (axiom₃ : ∀ (e : ω.entity) (h : e.pexemplifies p),
              let r := (entity.mk (p e) (axiom₂ e) h) in
              e.perfect → r.subsists e
    )
    (axiom₄ : ∀ (e : ω.entity), e.pexemplifies p → e.imperfect → p.dere_of e)

/-- The *significatum* or *res significata* is the entity signified by a possessed predicate `p`,
    i.e. the entity such that its existence causes the truth of the predication
    for some entity `e`. -/
def predicate.possessed.sign {p : ω.predicate} (h : p.possessed)
                                     {e : ω.entity} (ne : e.pexemplifies p)
                                     : ω.entity := ⟨p e, h.axiom₂ e, ne⟩

/-  Intensionally, the previous definition is intended to be open to the idea
    that the *significatum* of a predicate with respect to an entity
    might be an intensional entity, and which entity it is might
    even vary across possible worlds. Nevertheless, any two intensional
    *siginificata* of a *de re* necessary predicate must be existentially
    equivalent, so for this case the definition returns the corresponding extensional
    entity. Introducing intensional *significata* for extensional predicates
    would require an additional primitive beyond the introduction of an intensional
    ontology, but it might be useful for e.g. defending an **intensional** distinction between
    essence and existence/being (*esse*), if one is of the interpretation that the Thomistic distinction
    is an intensional one. We however are not of this latter position, so we prefer
    rather to introduce an **extensional** distinction between essence and existence,
    that we present further below. -/

-- TODO: consider changing the name of these definitions in the future to potentially
-- avoid the same Kit Finean "essence is not de re necessity" objection we wished to avoid
-- when renaming "essential" to "dere".

-- A possessed predicate is accidental of an entity if it is not essential.
-- From this we can infer (informally) that a predicate is either essential or accidental
-- of an entity or does not "talk about" an entity at all
-- (or at least does not "talk about" all entities to which it is predicated).
@[reducible]
def predicate.accidental_of (e : ω.entity) := p.possessed ∧ p.ndere_of e
@[reducible]
def predicate.accidental := p.possessed ∧ p.adere

-- Notice there can be possessed predicates which are neither essential nor accidental in themselves,
-- but only with respect to a particular entity (it is in this sense that some say heat is
-- essential of fire but accidental of burning coal). But with respect to any particular entity
-- a possessed predicate is either essential or accidental. Notice also that this sort of predicate
-- is (almost) never univocal, because predicating something of both a substance and its accidents is never univocal.

-- a "proper" predicate, or a predicate in a more "proper" sense of the word,
-- is an univocal possessed predicate
structure predicate.proper extends predicate.possessed p : Prop :=
    (axiom₅ : p.univocal)

variables (e : ω.entity) (ev : ω.event)

def predicate.bindp  : ω.predicate :=
  assume e₂, if e = e₂ then ev else p e₂

def predicate.localize : ω.predicate := (⊥ : ω.predicate).bindp e (p e)

variables (e) (p) (ev)

@[reducible, simp]
def entity.bindp : ω.predicate := p.bindp e ev

@[reducible, simp]
def entity.localize (p : ω.predicate) : ω.predicate := p.localize e

/-- The existence of an entity is the "existence" predicate localized to that entity.
    It is an essential proper predicate from which all of its essential predicates
    follow, or as Aquinas puts it, existence (esse) is the greatest
    perfection of a thing, as it actualizes its very essence. -/
def entity.existence : ω.predicate := ω.existence.localize e

-- Note: "esse" used above is often translated as "existence" but this translation
-- has been disputed (see works of Cornelio Fabro CSS for an idea). More properly,
-- we consider "esse" to refer to "being" in Thomistic philosophy, which we shall
-- define further down.

theorem existence_dere : e.existence.dere := sorry
theorem existence_proper : e.existence.proper := sorry
theorem existence_follows_dere : p.dere_of e → e.existence ≤ p  := sorry

/-- The haecceity of an entity is its incommunicable individual essence.
    It differs from the existence of an entity in that while the existence
    is *de re* necessary, the haecceity is absolutely necessary, or alternatively,
    haecceity predication does not have existential import, while
    existential predication (obviously) does.
    However, for the necessary being existence and haecceity coincide. -/
def entity.haecceity : ω.predicate := λ e₂, {w | e = e₂}

theorem existence_haecceity_distinction : e.existence = e.haecceity ↔ e.necessary :=
  begin
    simp [ entity.existence
         , entity.haecceity
         , predicate.localize
         , predicate.bindp
         , existence
         , function.funext_iff
         , -entity_ext_iff
         ],
    constructor; intro h,
      ext w,
      simp [nbe, univ, has_mem.mem, set.mem],
      specialize h e w,
      replace h := h.2,
      simp at h,
      exact h true.intro,
    intros e₂ w,
    by_cases c : e = e₂; simp [c],
      rw h at c,
      simp [nbe, ext_iff] at c,
      specialize c w,
      exact ⟨λ_,true.intro, λ_,c⟩,
    refine ⟨_, false.elim⟩,
    intro hyp,
    simp [ has_bot.bot
         , order_bot.bot
         , bounded_lattice.bot
         , complete_lattice.bot
         ] at hyp,
    exact hyp,
  end

-- a predicate is communicable if it can be possibly exemplified by more than one entity
def predicate.communicable := ∃ e₁ e₂ : ω.entity,
                             e₁ ≠ e₂ ∧
                             e₁.pexemplifies p ∧
                             e₂.pexemplifies p

def predicate.incommunicable := ¬ p.communicable

-- the individual existence of an entity is of course incommunicable
lemma existence_incommunicable : e.existence.incommunicable := sorry

-- and so is its haecceity
lemma haecceity_incommunicable : e.haecceity.incommunicable := sorry

-- A normal, "everyday", predicate like "being red"
-- (when e.g. it is predicated of substances, and not of "red" accidents)
-- is a communicable proper predicate.
structure predicate.normal extends predicate.proper p : Prop :=
    (axiom₆ : p.communicable)

-- Don't know if this is true
-- there are counterexamples when S contains contradictory predicates
-- but otherwise maybe an adaptation of this lemma is true
-- lemma inf_normal_normal : ∀ S : set ω.predicate, (∀ p : ω.predicate, p ∈ S → p.normal) → (Inf S).normal :=
--     begin
--         intros S h,
--         have ne : S.nonempty,
--             admit,
--         obtain ⟨p, hp⟩ := ne,
--         have pn := h p hp,
--         constructor,
--             admit,
--         obtain ⟨e₁,e₂,neq, he₁,he₂⟩  := pn.axiom₆,
--     end

-- The specific essence, or species, of an entity is a normal essential predicate from which
-- all its normal essential predicates follow.
def predicate.species_of := e.pexemplifies p ∧
                           p.normal ∧
                           p.dere ∧
                           ∀ p', e.pexemplifies p' →
                                p'.normal →
                                p'.dere →
                                p ≤ p'

def predicate.species := ∃ e, p.species_of e
def entity.has_species := ∃ p : ω.predicate, p.species_of e

-- An entity has at most one species
lemma unique_species : ∀ p₁ p₂ : ω.predicate, (∃ e, p₁.species_of e ∧ p₂.species_of e) → p₁ = p₂ := sorry

-- Now, essence is predicated in multiple ways, the foremost
-- of which is in the sense of species. However, among
-- things which have no species, essence only signifies haecceity,
-- leading us to the following definition:

/-- A predicate is the essence of an entity if it is either its specific essence or its haecceity. -/
def entity.is_essence := p.species_of e ∨ p = e.haecceity

-- We can then prove essence × existence distinction as well:
theorem existence_essence_distinction : e.is_essence e.existence ↔ e.necessary := sorry

end predicates

section apredicates

  variables (p : ω.apredicate) (e : ω.entity)

  def apredicate.sup := Sup (subtype.val '' (range $ p e))
  def apredicate.inf := Inf (subtype.val '' (range $ p e))
  def apredicate.max := Sup ⋃ e, (subtype.val '' (range $ p e))
  -- def apredicate.min := Inf ⋃ e, (subtype.val '' (range $ p e)) -- I think maybe this is always 0
  def apredicate.complete := p.max = 1

  def apredicate.existential := ∀ e, ↑(p e) ⊆ e.exists

end apredicates

section happiness

  variables (e : ω.entity) (p : ω.apredicate)

  /-- An `entity` is said to be **happy**, or **naturally perfect**, w.r.t some apredicate `p` in possible world `w`
      if it attains the greatest degree of `p` it can achieve, at `w`. -/
  def entity.happy : ω.event := {w | e.exists w ∧ ↑(p e w) = p.sup e}

  /-- An `entity` is said to be **wholesome** w.r.t some apredicate `p`
      if it can possibly be happy w.r.t. `p`. -/
  def entity.wholesome := ⋄e.happy p

  /-- An `entity` is said to be **miserable** w.r.t some apredicate `p`
      if it cannot possibly be happy w.r.t. `p`. -/
  def entity.miserable := ¬ e.wholesome p

  -- TODO: maybe this one should be generalized to arbitrary observables.
  def entity.invariantly := ∀ w₁ w₂, e.exists w₁ → e.exists w₂ → p e w₁ = p e w₂
  def entity.invariantly_happy := e.invariantly p ∧ e.wholesome p
  def entity.absolutely_happy := □e.happy p

  /-- A **maximally perfectible** `entity` w.r.t some apredicate `p` is one which
      can possibly be progressively perfected in the direction of attaining
      the greatest degree of `p` that is possible for any entity to have. -/
  def entity.mperfectible := p.sup e = p.max

  /-- A **completely perfectible** `entity` w.r.t some apredicate `p` is one which
      can possibly attain the greatest conceivable degree of `p`. -/
  def entity.cperfectible := ∃ w, p e w = 1

  /-- An `entity` is said to be **exemplary** w.r.t some apredicate `p` in some possible world `w`
      if it is maximally perfectible in itself and happy at `w`. -/
  def entity.exemplary : ω.event := {w | e.mperfectible p ∧ e.happy p w}

  /-- An `entity` is said to be an **exemplary cause of `p`**, or an **examplar** w.r.t some apredicate `p`,
      if it can possibly attain the greatest degree of `p` that is possible for any entity to achieve.
      i.e. it is an entity which is possibly `exemplary`. -/
  @[reducible, simp]
  def entity.ecause := ⋄e.exemplary p

  /-- An apredicate is **exemplarily caused** if it admits an `exemplar`. I.e., an
      `entity` which  can possibly attain the greatest degree of `p` that is
      possible for any entity to have. -/
  def apredicate.ecaused := ∃ e : ω.entity, e.ecause p

  /-- An `entity` is said to be **absolutely exemplary**, or **maximally perfect**, w.r.t some apredicate `p`
      if it is exemplary in every possible world. -/
  @[reducible, simp]
  def entity.absolutely_exemplary := □e.exemplary p
  /-- "**Maximally perfect**" is an alias for `absolutely_exemplary`. -/
  @[reducible, simp, alias]
  def entity.mperfect := e.absolutely_exemplary

  /-! # The Intuition behind exemplary causes.

      The property of real numbers of being "close" to a given
      number, say `5`, is an analogical predicate which admits an exemplary cause,
      namely `5`. We can define this predicate as something like `close₅(x) = 1 ÷ (∥x - 5∥ + 1)`,
      as we can see that `close₅(5) = 1`, `∥x∥ ⇒ +∞, close₅(x) ⇒ 0`, `∀x, 0 ≤ close₅(x) ≤ 1`.
      This predicate defines a so called "fuzzy set" of real numbers:
      the real numbers which are "close" to `5`.
      The number `5` is called an **exemplary cause** of the predicate `close₅`
      because, given the fact that it attains the greatest conceivable degree of `close₅`,
      it also serves as an ultimate criteria of comparison for determining the extent to which a real number is
      close to `5`, i.e. a number will attain higher degrees of `close₅` precisely to the extent to which
      it is close to `5`. `close₅` can then be deemed a *measure of similarity to a point*, namely the point
      `5`, the **exemplar**.

      What other kinds of predicates are measures of similarity to a point in a similar way? It appears
      that natural and moral perfections are good candidates for being exemplarily caused.
      We have an intuitive grasp, for instance, of what a good, or healthy, dog is, insofar as we can imagine
      a "perfect" dog. The dog of our dreams is one which, perhaps,
      is very strong, playful, healthy and active, lives by a healthy diet,
      is cheerful, gets a lot of sunlight, exercises regularly,
      is a very effective apologetics minister by
      putting the fear of God into the hearts of burglars and trespassers,
      is docile, etc...
      It is the kind of dog you would likely see portrayed in a dog food commercial, or
      something of the sort. He is the exemplar of what the natural powers of dogs
      can achieve when they operate in the most perfect way possible. It is an ideal dog,
      and just like with any ideal we can't help but measure other dogs with respect it.
      There are then clearly different degrees to which a dog can fully achieve the potential
      of its nature, so that we can even say, that the exemplar dog is a dog
      *in the proper sense of the word*, or absolutely, *simpliciter*, without qualification,
      while dogs not measuring up to its standards are only dogs in a more limited sense of the word,
      with qualification, relatively, or *secundum quid*. All dogs can in a sense be said to
      *participate* of the exemplar dog to the extent that they are similar to it, in a way reminiscent
      to how things were supposed by Plato to participate in their Platonic forms.

  -/

  theorem inner_life_of_the_absolutely_exemplary : e.absolutely_exemplary p ↔ e.absolutely_happy p := sorry

  lemma necessary_of_abs_exemplary : e.absolutely_exemplary p → e.necessary := sorry

end happiness

section being

/-! # The Analogy of Being

   We have seem that existence is not truly an univocal property, but a hidden analogy.
   This is obvious from the consideration that substances possess a higher degree
   of existence than their accidents, insofar as the accidents do not subsist of themselves,
   but must inhere in a substance. The analogical nature of existence formally follows
   from the fact that accidents entail the existence of their substances.

   As such we should expect there to be an analogical predicate from which existence is abstracted,
   and with respect to which "existence" will, in a sense, come by degrees. However,
   because we typically think of existence as an univocal property, having no degrees,
   we shall name this "existence" which comes by degrees **being**, rather than existence.
   Another, way to see that this "being" has degrees is to consider that being is identical
   in reality to other two so called *transcendental properties* which quite clearly have degrees, namely
   unity and actuality, which are called so because anything that exists is one individual unified thing
   and also actual. And this we can show not only by comparing accidents to substances, but also from
   comparing substances to substances.

   We observe in reality that things are more or less unified and more or less actual;
   the first we notice from the fact that all natural entities have an intrinsic unification principle which
   unifies their parts more or less, allowing the entity to be more or less complex. At the bottom of the hierarchy
   of unity we have gases, for which the unification principle is the weakest insofar as whatever
   unifies gases in a whole is not strong enough to give them a definite shape, which is rather imposed from
   without, by an external container. Next we have liquids which possess greater solidity, and hence unification,
   than gases, but are still not unified enough to possess their own shape; though they already exhibit some
   resistance against compression. We then have solids which are unified enough to have their own shapes
   and are often much more resistant to compression and various pressures than the previous.
   Plasmas are however harder to classify since the ancients would equate them with fire, which was considered
   the most perfect of the 4 elements, though fire has a less stable shape than a solid, so it is unclear whether
   they should be considered more perfect than solids or not. After the minerals, however, we have living organisms
   which are much more unified and complex than any minerals, and among them we have animals which exhibit
   even greater complexity and unification, and finally we have humans, which unify physical and metaphysical
   substances into the same whole.

   On the other hand, we have among these levels also greater degrees of actuality, since a thing is able
   to act more perfectly insofar as it is more actual, and yet anything is actual insofar as it exists. A natural
   entity is more actual to the extent that it has more energy and is habitually capable of using this energy
   to perform more complex vital operations. It is in this respect that fire/plasma is the most perfect state of
   inanimate matter, but any living organism is more perfect than it insofar as its energy does not come in the
   form of useless heat, but of direct and complex vital operations.

   It is furthermore the case that natural substances vary in perfection with respect to time,
   becoming more or less perfect depending on the circumstances. A good man can be said to be more
   perfect than a bad one, in a moral sense of the word "perfect", while a healthy man can be said
   to be more perfect than an unhealthy one, in a more natural or biological sense of the word.

   These considerations suffice for showing that natural entities exhibit greater or lesser degrees of perfection,
   but we must also extend this consideration to metaphysical entities. Metaphysical entities which have no parts,
   spatial extension and, specially, accidents, are more perfect than natural entities, not on account of a greater
   amount of complexity or energy, but on account of their greater unification and actuality. Unification
   in natural entities which have parts is exhibited in complexity insofar as a greater unifying principle is required
   to amalgamate a multiplicity of disparate entities into a single unified whole; however the more unified
   a substance is the less will their parts behave like disparate or independent entities to begin with.
   As the unity of a substance increases, its parts become so intertwined with it that
   they begin to exhibit fundamental ontological dependencies to the whole, and vice-versa.
   This is already observable in the case of living animals,
   for which the removal of an organ causes the death of the same organ,
   and often the death of the animal, in a very short period of time;
   unless artificial means are used to keep them alive.
   In the limit, this ontological dependencies would grow to become full existential dependencies,
   so that it would be impossible to distinguish a substance from its parts by extensional means,
   and we could simply say that the substance has no parts, because it has "absorbed" all of its "parts"
   within itself. A substance of this sort would exhibit greater unification than any natural
   entity, even though it would be absolutely simple.

   With respect to extension, metaphysical substances are more perfect, insofar as to have extension
   is but to be limited to a particular (compact, connected) region of space, outside of which
   the substance has no existence, while a substance without extension can be said to exist in all points
   of space without limits, as we shall later formalize (in geometry.lean). Furthermore it is obvious
   that simple substances, which have no accidents, are more perfect than composite substances
   due to the the multiplicity of states being the origin of a multiplicity
   of different ways of existing and of passive potentiality, and being the multiplicity of possible accidents
   the origin of the multiplicity of states, it is clear that a substance without accidents has no
   passive potentiality (outside perhaps of a potentiality for existence or non-existence) and no multiplicity
   of ways of existing, hence being much more unified and actual than any substance with accidents.

   Finally, metaphysical entities which are necessary are clearly more perfect than contingent ones,
   just as any substance which depends on another, should be less perfect than this other.
   These considerations suffice to show then that even among metaphysical substances,
   or when comparing metaphysical substances to natural ones, there are differing degrees of
   unification, actuality and, hence, also perfection and being. -/

  /-- The **Being**, **analogy of being**, or *actus essendi* of an ontology is an `apredicate` **is**
      which gives to every possible entity in every possible world the degree of being,
      or degree of perfection, that the entity has in that world.
      This perfection, or degree of being, is also a measurement of the degree of actuality of an entity,
      as it varies across possible worlds. Substances which are invariant with respect to
      being, are less fleeting, and as such more actual, while substances which vary greatly in being
      are more fleeting, more potential and, hence, less perfect in being. They are also less unified,
      less truthful, less good, less beautiful, etc... for all the so called *transcendentals of being*. -/
  structure being (ω : ontology) :=
    (is : ω.apredicate)
    -- Being is synonymous with existence,
    -- in the sense that an entity can only have
    -- being in any capacity or amount whatsoever
    -- if it exists, and to exist is nothing other
    -- than to participate in being to some extent
    -- or to some capacity. Existence is abstracted
    -- from being.
    (axiom₁ : ∀ e, ↑(is e) = e.exists)
    -- Being respects the hierarchies of ontological dependencies,
    -- indeed it is the very **origin** of said hierarchies. The most
    -- basic relation of ontological dependency is existential entailment,
    -- so entities which depend existentially on another shall be less perfect than
    -- that other, in any possible worlds in which they exist.
    (axiom₂ : ∀ e₁ e₂ : ω.entity, e₁ ≠ e₂ → e₁.exists ⇒ e₂.exists → is e₁ < is e₂)
    -- Being is complete, for it if were not then the maximum degree
    -- of perfection attainable by an entity would necessarily fall short
    -- of 100% of the maximum degree of perfection attainable by an entity, which is absurd.
    -- i.e., an entity that has degree of perfection 1.0 in any possible world
    -- is to be interpreted as having attained the maximum possible degree of perfection
    -- any entity could possibly achieve.
    (axiom₃ : is.complete)
    -- A substance is more or less perfect across possible worlds only because of the variability
    -- of the accidents inhering in it, so in worlds in which a substance has the same state
    -- it should have the same degree of perfection also.
    (axiom₄ : ∀ (s : ω.substance) (w₁ w₂), s.equiv w₁ w₂ → is s.up w₁ = is s.up w₂)
    -- Furthermore, in worlds in which more things subsist in a substance, it should also
    -- be more perfect, for the perfection of the subsistent entities should, in some
    -- sense, "add up" to an increase in the overall perfection of the substance.
    (axiom₅ : ∀ (s : ω.substance) (w₁ w₂), s.state w₁ ⊂ s.state w₂ → is s.up w₁ < is s.up w₂)
    -- Furthermore, states were not defined for accidents since nothing subsists in them.
    -- It should follow that accidents have being invariantly, for without variation of
    -- accidents there can be no variation of perfection.
    (axiom₆ : ∀ (a : ω.accident), a.up.invariantly is)
    -- In any possible world in which a simple substance exists, it is more perfect
    -- than all composite substances existing in the same world.
    -- Note: this does not assume that it is possible for simple substances to exist,
    -- only that **if** they do exist, they are more perfect than the composites.
    -- We also do not need this axiom to show that God is more perfect than composite things,
    -- for this follows from axiom 2, but rather we only need it to show that other, contingent,
    -- simple substances are more perfect than composite substances.
    (axiom₇ : ∀ (s₁ : ω.substance) (w), s₁.simple → s₁.exists w →
      ∀ (s₂ : ω.substance), s₂.composite → s₂.exists w → is s₂.up w < is s₁.up w)
    -- If two entities are of the same species, it should be
    -- possible for both to achieve exactly the same levels of
    -- perfection. TODO: number this axiom and make sure the numbering is consistent
    -- with pextensions.
    (axiom_to_number : ∀ (e₁ e₂ : ω.entity) (p : ω.predicate), p.species_of e₁ → p.species_of e₂ → range (is e₁) = range (is e₂))

  variable (b : ω.being)
  open predicate

  -- The necessary being is maximally perfectible w.r.t. any analogy of being.
  -- Only needed axiom₂ for this proof.
  lemma nbe_mperfectible : ω.nbe.mperfectible b.is :=
    begin
      simp [entity.mperfectible],
      symmetry,
      apply cSup_intro,
      -- goal 1
        obtain ⟨w⟩ := ω.wne,
        use b.is ω.nbe w,
        simp,
        constructor,
          exact (b.is (nbe ω) w).property,
        use ω.nbe, use w,
      -- goal 2
      intros r H,
      simp at H,
      obtain ⟨e, hr, w, eq⟩ := H,
      set rhs := apredicate.sup b.is (nbe ω),
      let r₂ := b.is ω.nbe w,
      transitivity r₂.val, swap,
        apply le_cSup, swap,
          simp [range, image],
          constructor,
            exact r₂.property,
          use w,
        simp [bdd_above, upper_bounds],
        use 1, simp, intros r₃ hr₃ _,
        simp [set.Icc] at hr₃,
        exact hr₃.right,
      by_cases h : e = ω.nbe,
        simp [r₂],
        rw [←h, eq],
      have c := b.axiom₂ e ω.nbe h _, swap,
        simp [ontology.nbe, set.subset],
      replace c := c.left w,
      rw eq at c,
      exact c,
      -- goal 3
      intros r hr,
      obtain ⟨r₂, hr₂, c⟩ := exists_lt_of_lt_cSup _ hr,
      use r₂,
      simp [range, image] at hr₂,
      simp [hr₂, c],
      use ω.nbe,
      exact hr₂,
      obtain ⟨w⟩ := ω.wne,
        use b.is ω.nbe w,
        simp,
        constructor,
          exact (b.is (nbe ω) w).property,
        use w,
    end

  /-- Misery begets misery. A wholesome entity should not depend on a miserable one.
      analogies of `being` satisfying this principle are said to be **proportionally happy**, for they
      satisfy a form of proportionate causality with respect to happiness. -/
  def being.phappy : Prop := ∀ (e₁ e₂ : ω.entity) w, e₁.happy b.is w → (e₁.exists ⇒ e₂.exists) → e₂.happy b.is w

  /-- An analogy of `being` is said to be **wholesome** if some `entity` is `wholesome` with respect to it. -/
  def being.wholesome : Prop := ∃ e : ω.entity, e.wholesome b.is

  /-- An analogy of `being` is said to be **absolutely exemplary** if some `entity` is `absolutely exemplary` with respect to it. -/
  def being.absolutely_exemplary : Prop := ∃ e : ω.entity, e.absolutely_exemplary b.is

  -- exemplary

  /-- An analogy of `being` is said to be **Exemplarily Caused** if it is exemplifiable.
      I.e. if some `entity` is an **exemplary cause** (`ecause`) of being. -/
  def being.ecaused : Prop := b.is.ecaused

  lemma ecaused_of_phappy_and_wholesome : b.phappy → b.wholesome → b.ecaused := sorry

  lemma exemplar_nbe_of_ecaused : b.ecaused → ω.nbe.ecause b.is := sorry

  /-- The perfection of a multitude of entities should increase with the number of entities.
      Analogies of `being` satisfying this principle are called **composable**. -/
  def being.composable := ∀ (s : set ω.entity) (e : ω.entity) (w₁ w₂ : ω.world),
                            e ∉ s →
                            e = Sup s →
                            w₁.entities ∩ s ⊂ w₂.entities ∩ s →
                            b.is e w₁ < b.is e w₂

  /-- An analogy of `being` is said to be **essentially exemplary** if it is essential for entities to be exemplary
      with respect to it.
      Nothing could explain otherwise why an entity would be exemplary in one world
      but not in some other.
       -/
  def being.eexemplary  : Prop := dere (flip entity.exemplary b.is)

  lemma abs_exemplary_intro {b : ω.being} : b.ecaused → b.eexemplary → b.absolutely_exemplary := sorry
  lemma nbe_eq1_of_abs_exemplary {b : ω.being} : b.absolutely_exemplary → ∀ w, b.is ω.nbe w = 1  := sorry

  /-- A **quasi-participated** `being` is essentially exemplary and exemplarily caused. -/
  @[reducible, simp]
  def being.qparticipated := b.ecaused ∧ b.eexemplary

  def being.participated := b.composable ∧ b.qparticipated

  def participated (ω : ontology) := ∃ b : ω.being, b.participated
  def composable (ω : ontology) := ∃ b : ω.being, b.composable
  def exemplary (ω : ontology) := ∃ b : ω.being, b.absolutely_exemplary

  lemma exemplary_of_participated : ω.participated → ω.exemplary :=
    begin
      rintro ⟨b, hbc, hbs, hbes⟩,
      use b,
      exact abs_exemplary_intro hbs hbes,
    end

section pextension

  /-- A **Platonic Extension** equips every property of a certain kind (e.g. normal) with an analogical extension,
      satisfying certain properties. These include possessing the predicate in a more perfect way
      than whatever possesses it in the usual way, i.e. "formally".
       This is done so that the concept of **eminence** can be defined. -/
  structure pextension (ω : ontology) (prop : ω.predicate → Prop := predicate.normal) extends being ω :=
    -- To every univocal, normal, predicate there corresponds some
    -- analogical predicate
    (extended : Π (p : ω.predicate) (h : prop p), ω.apredicate)
    -- from which it was at least partially abstracted.
    -- This means all entities having the predicate have the analogical predicate, in some
    -- capacity, or to some extent.
    (axiom₈  : ∀ (p : ω.predicate) (h : prop p) e, p e ⊆ ↑(extended p h e))
    -- However, whatever has the apredicate to some capacity but does not have the predicate,
    -- has the predicate to a strictly greater or more perfect extent than anything which can possibly
    -- have the predicate.
    (axiom₉  : ∀ (p : ω.predicate) (h : prop p) e₁ w₁, w₁ ∈ ↑(extended p h e₁) - p e₁ →
      ∀ e₂ w₂, p e₂ w₂ → extended p h e₂ w₂ < extended p h e₁ w₁)
    -- The apredicate is always existential
    (axiom₁₀  : ∀ (p : ω.predicate) (h : prop p), (extended p h).existential)
    -- Equality in being implies equality in the perfection of the analogical extension
    (axiom₁₁  : ∀ (p : ω.predicate) (h : prop p) e (w₁ w₂), is e w₁ = is e w₂ → extended p h e w₁ = extended p h e w₂)
    -- We stipulate also that the class of predicates prop, has to satisfy certain conditions in order to admit
    -- a platonic extension. All of these conditions are satisfied by the default (predicate.normal).
    (condition₁ : ∃ p, prop p)
    (condition₂ : ∀ (p : ω.predicate), prop p → p.exemplifiable)

  variables {prop : ω.predicate → Prop} (ext : ω.pextension prop) (p : ω.predicate) (h : prop p)

  def entity.eminently (e : ω.entity) : ω.event := {w | ¬ p e w ∧ ext.extended p h e w ≠ 0 }

  def entity.eminent (e : ω.entity) : Prop := e.eminently ext p h = e.exists

  def pextension.non_trivial := ∃ (p : ω.predicate) [h : prop p] (e : ω.entity), ⋄e.eminently ext p h

end pextension

end being

end ontology


-------------------------------------------------------------------
-- The PEDANTIC (Proof Engine for Deductive Automation using Non-deterministic
-- Traversal of Instruction Code) verification framework
--
-- Developed by Kenneth Roe
-- For more information, check out www.cs.jhu.edu/~roe
--
-- AbsExecute.v
-- This file contains the basic hoare triple definition and many auxiliary theorems
-- and definitions related to forward propagation.
--
-- Some key definitions:
--     absExecute
--     hoare_triple
--     strengthenPost
--     assign
--     basic_assign
--     load_traverse
--     load
--     store
--     new_thm
--     delete_thm
--     if_statement
--     while
-------------------------------------------------------------------

import .impHeap
import .AbsState

open tactic
open monad
open expr
open smt_tactic

-------------------------------------------------------------------

--def In {A:Type} : A → list A → Prop
--| _ list.nil := false
--| a (b :: m) := b = a ∨ In a m

def absExecute (funs : functions)
               (c : com)
               (s : absState)
               (s' : absState)
               (r : list (@absExp ℕ))
               (s'' : absState)
               (exc : ident → ((@absExp ℕ) × absState)) : Prop :=
    ∀ st st' i x,
        realizeState s st →
        ((∃ st', ∃ r, ceval funs st c st' r) ∧
         ((ceval funs st c st' func_result.NoResult → realizeState s' st') ∧
          (ceval funs st c st' (func_result.Return x) →
            ((∀ rx, rx ∈ r → @absEval ℕ (st'.snd) rx = x) ∧ realizeState s'' st')) ∧
          (ceval funs st c st' (func_result.Exception i x) → (@absEval ℕ (st'.snd) ((exc i).fst) = x ∧ realizeState ((exc i).snd) st'))))

def hoare_triple (P : absState) (c : com) (Q : absState) (r : list (@absExp ℕ)) (Qr : absState) (exc : ident → ((@absExp ℕ) × absState)) : Prop :=
    absExecute (λ x y z a b, ff) c P Q r Qr exc.

notation `{{ ` P ` }} ` c ` {{ ` Q ` }}` := (hoare_triple P c Q list.nil absNone (λ (x:ident), ((λ (x:env), 0),absNone))).
notation `{{ ` P ` }} ` c ` {{ ` Q ` return ` rr ` with ` QQ ` }}` := (hoare_triple P c Q rr QQ (λ (x:ident), ((λ (x:env), 0),absNone))).

theorem override_equal : ∀ env v, override env v (env v)=env :=
begin
    intros, unfold override, funext,
    by_cases (v=l),rewrite h,simp,
    simp [h]
end

--theorem fun_ext {t} {u} :
--    ∀ (a:t→u) (b:t→u), a=b → (λ (x:t), a)=(λ (x:t), b) :=
--begin
--    assume a b h, by rw h
--end

theorem double_override : ∀ env v v1 v2, override (override env v v1) v v2=override env v v2 :=
begin
    intros, unfold override,
    have h:(∀ l, (ite (v=l) v2 (ite (v=l) v1 (env l)))=
            ite (v=l) v2 (env l)),
    intros, by_cases (v=l), rewrite h, simp,
    simp [h], simp only [h]
end

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

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

theorem assignPropagate: ∀ (P : absState) (v:ℕ) e xx,
    hoare_triple P  (v ::= e)
          (absExists
              (λ vv, ( (λ st, (P  ** (absPredicate (λ ee, aeval ee e=st.snd v)))

                       (override_state v vv st))
           ))) [] absNone xx :=
begin
    unfold override_state,

    unfold hoare_triple, intros, unfold absExecute,
    intros, split,

    existsi _, existsi _, apply ceval.Ass,

    unfold realizeState at a, split, intro, cases a_1,

    unfold realizeState, unfold absExists,
    existsi (st.snd v), unfold absCompose, existsi _, existsi _,
    simp, split,

    have h:(P ((st.fst, override (st.snd) v (aeval (st.snd) e)).fst,
         override ((st.fst, override (st.snd) v (aeval (st.snd) e)).snd) v (st.snd v))), swap,
    apply h, simp, rw double_override, rw override_equal,
    cases st, simp, apply a,

    swap, apply ((empty_heap, override (st.snd) v (aeval (st.snd) e)).fst,
         override ((st.fst, override (st.snd) v (aeval (st.snd) e)).snd) v (st.snd v)),

    simp,split, unfold absPredicate, simp, rewrite double_override,
    rw override_equal, unfold override, simp,

    simp, rw double_override, rw override_equal,
    unfold concreteCompose, simp, split,

    intro, right, unfold empty_heap, unfold inhabited.default,
    unfold empty_heap, unfold inhabited.default,
    unfold compose_heaps, simp only [nonethm2],

    --cases st, have h:(∀ x, compose_heaps st.fst empty_heap x = st.fst x),

    --intro, unfold compose_heaps, generalize el:(st.fst x_1)=qq,
    --cases qq, unfold empty_heap, unfold inhabited.default,
    --apply nonethm,

    --unfold empty_heap, unfold inhabited.default,
    --simp only [compose_heaps._match_1],
    --tactic.funext,apply h,

    split, intros, split, intros, cases a_2, cases a_1,
    intros, cases a_1

end

--set_option trace.simp_lemmas true.
--set_option trace.simplify true.

theorem strengthenPost : ∀ (R : absState) (P : absState) (Q : absState) (C : com),
                         {{ P }} C {{ Q }} →
                         (forall st, Q st → R st) →
                         {{ P }} C {{ R }} := begin
    intros, unfold hoare_triple at a, unfold absExecute at a,
    unfold hoare_triple, unfold absExecute,
    intros,
    specialize a st st' i x,
    simp, simp at a,
    have hh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st')) ∧
    ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st'
          func_result.NoResult →
        realizeState Q st') ∧
       (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st'
            (func_result.Return x) →
          realizeState absNone st') ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st C st'
            (func_result.Exception i x) →
          absEval (st'.snd) (λ (x : env), 0) = x ∧ realizeState absNone st'))),
    apply a, apply a_2,
    cases hh, split, apply hh_left,
    cases hh_right, split, intros, apply a_1, apply hh_right_left,
    apply a_3, cases hh_right_right, split, intros,
    exfalso, unfold realizeState at hh_right_right_left,
    unfold absNone at hh_right_right_left,
    apply hh_right_right_left, apply a_3,
    intros, exfalso,unfold realizeState at hh_right_right_right,
    unfold absNone at hh_right_right_right,
    simp at hh_right_right_right,
    apply hh_right_right_right, apply a_3
end

theorem nilmem {t} (x : t) : x ∈ @list.nil t=false :=
begin
    simp
end

theorem rsfalse { st : imp_state} : realizeState absNone st=false :=
begin
    unfold realizeState, unfold absNone
end

theorem andfalse { a : Prop } : (a ∧ false)=false :=
begin
    simp
end

theorem compose : forall (P:absState) c1 c2 Q R,
    {{ P }} c1 {{ Q }} →
    {{ Q }} c2 {{ R }} →
    {{ P }} (com.Seq c1 c2) {{ R }} := begin
    intros, unfold hoare_triple at a, unfold hoare_triple at a_1,
    unfold absExecute at a, unfold absExecute at a_1,
    unfold hoare_triple, unfold absExecute,
    intros,
    simp at a_1, simp at a,
    simp,
     simp only [rsfalse] at a, simp only [andfalse] at a,
     simp only [rsfalse] at a_1, simp only [andfalse] at a_1,

     have aaa:(∀ (st' : imp_state), (∃ (st' : imp_state),
         Exists
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1
              st')) ∧
      ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
            func_result.NoResult →
          realizeState Q st') ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Return x) →
            false) ∧
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Exception i x) →
            false))),
    intros, apply a, apply a_2,
    split,
    have aaa2:(  ∀ (st' : imp_state),
    (∃ (st' : imp_state),
         Exists
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1
              st')) ∧
      ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
            func_result.NoResult →
          realizeState Q st') ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Return x) →
            false) ∧
           (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) st c1 st'
              (func_result.Exception i x) →
            false))), apply aaa,

    specialize aaa st', cases aaa, cases aaa_left, cases aaa_left_h,
    cases aaa_left_h_w,

    have aa1:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2
            st')) ∧
    ((ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2 st'
          func_result.NoResult →
        realizeState R st') ∧
       (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2 st'
            (func_result.Return x) →
          false) ∧
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) aaa_left_w c2
            st'
            (func_result.Exception i x) →
          false))), apply a_1,
    specialize aaa2 aaa_left_w, cases aaa2, cases aaa2_right,
    apply aaa2_right_left, apply aaa_left_h_h,
    cases aa1, cases aa1_left, cases aa1_left_h,

    existsi aa1_left_w, existsi aa1_left_h_w,
    apply ceval.Seq1, apply aaa_left_h_h,
    --specialize a_1 aaa_left_w st' i x,

    apply aa1_left_h_h,

    existsi _, existsi _,
    apply ceval.Seq2, apply aaa_left_h_h,

    existsi _, existsi _,
    apply ceval.Seq3, apply aaa_left_h_h,

    split,
    intros,
    cases a_3,
    specialize aaa a_3_st', cases aaa, cases aaa_right,
    specialize a_1 a_3_st' st' i x,

    have hh:(realizeState Q a_3_st' → (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult) →
  realizeState R st'),
    intros,
    have hhh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2
            st')) ∧
    (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult →
       realizeState R st') ∧
      (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Return x) →
         false) ∧
        (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Exception i x) →
         false)), apply a_1, apply a_3,
    cases hhh, cases hhh_right,
    apply hhh_right_left, apply a_4,

    apply hh, apply aaa_right_left, apply a_3_a, apply a_3_a_1,

    split, intros, unfold realizeState, unfold absNone,
    cases a_3,
    specialize aaa a_3_st', cases aaa, cases aaa_right,
    specialize a_1 a_3_st' st' i x,
    have hh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2
            st')) ∧
    (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult →
       realizeState R st') ∧
      (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Return x) →
         false) ∧
        (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Exception i x) →
         false)), apply a_1, apply aaa_right_left, apply a_3_a,
    cases hh, cases hh_right, cases hh_right_right,

    apply hh_right_right_left, apply a_3_a_1,
    specialize aaa st',
    cases aaa, cases aaa_right, cases aaa_right_right,
    apply aaa_right_right_left, apply a_3_a,

    intros, exfalso,
    cases a_3,
    specialize aaa a_3_st', cases aaa, cases aaa_right,
    specialize a_1 a_3_st' st' i x,
    have hh:((∃ (st' : imp_state),
       Exists
         (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2
            st')) ∧
    (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
         func_result.NoResult →
       realizeState R st') ∧
      (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Return x) →
         false) ∧
        (ceval (λ (x : ident) (y : imp_state) (z : list ℕ) (a : imp_state) (b : func_result), false) a_3_st' c2 st'
           (func_result.Exception i x) →
         false)), apply a_1, apply aaa_right_left, apply a_3_a,
    cases hh, cases hh_right, cases hh_right_right,

    apply hh_right_right_right, apply a_3_a_1,
    specialize aaa st',
    cases aaa, cases aaa_right, cases aaa_right_right,
    apply aaa_right_right_right, apply a_3_a
end

meta def evaluate_aeval_helper : expr → expr
| `(aeval %%e (aexp.Num %%x)) := x
| `(aeval %%e (aexp.Var %%v)) := e v
| `(aeval %%e (aexp.Plus %%x %%y)) :=
            `((%%(evaluate_aeval_helper `(aeval %%e %%x))) +
              (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Minus %%x %%y)) :=
            `((%%(evaluate_aeval_helper `(aeval %%e %%x))) -
              (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Mult %%x %%y)) :=
            `((%%(evaluate_aeval_helper `(aeval %%e %%x))) *
              (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Eq %%x %%y)) :=
           `((%%(evaluate_aeval_helper `(aeval %%e %%x))) =
             (%%(evaluate_aeval_helper `(aeval %%e %%y))))
| `(aeval %%e (aexp.Le %%x %%y)) :=
           `(%%(evaluate_aeval_helper `(aeval %%e %%x))≤
             %%(evaluate_aeval_helper `(aeval %%e %%y)))
| `(aeval %%e (aexp.Land %%x %%y)) :=
      `(if ((aeval %%e %%x)=0) then 0 else (aeval %%e %%y))
--| `(aeval %%e (aexp.Land %%x %%y)) := `(if (aeval %%e %%x)=0 then 0 else (aeval %%e %%y))
| `(aeval %%e (aexp.Lor %%x %%y)) := `(if (aeval %%e %%x)=0 then (aeval %%e %%y) else (aeval %%e %%x))
| `(aeval %%e (aexp.Lnot %%x)) := `(if (aeval %%e %%x)=0 then 1 else 0)
| `(aeval %%e A0) := `(0)
| `(aeval %%e A1) := `(1)
| `(aeval %%e A2) := `(2)
| `(aeval %%e A3) := `(3)
| `(aeval %%e A4) := `(4)
| `(aeval %%e A5) := `(5)
| `(aeval %%e A6) := `(6)
| (expr.app a b) := expr.app (evaluate_aeval_helper a) (evaluate_aeval_helper b)
| (expr.lam v b t e) := expr.lam v b (evaluate_aeval_helper t) (evaluate_aeval_helper e)
| (expr.pi v b t e) := expr.pi v b (evaluate_aeval_helper t) (evaluate_aeval_helper e)
| x := x

meta def evaluate_aeval : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     --trace tgt.to_raw_fmt,
     nt ← some (evaluate_aeval_helper tgt),
     --trace nt.to_raw_fmt,
     change nt }

--theorem xx: 1=(2,2).fst :=
--begin
--    do {
--        xxx ← target,
--        trace xxx.to_raw_fmt,
--        admit
--    }
--end

set_option eqn_compiler.max_steps 9999
set_option timeout 10000

meta def simplify_override_helper : expr → expr
| `(λ st, (absCompose %%l %%r)
          (@prod.mk
           (@prod.fst st)
           (override (@prod.snd st) %%vv %%ee))) :=
  (expr.app (expr.app `(absCompose)
      (expr.lam "st" binder_info.default `(imp_state)
          (expr.app
            l
            (expr.app (expr.app `(@prod.mk heap env)
              (expr.app `(@prod.fst heap env) (expr.var 0)))
              (expr.app (expr.app (expr.app `(@override)
                 (expr.app `(@prod.snd heap env) (expr.var 0))) vv) ee)
              ))))
      (expr.lam "st" binder_info.default `(imp_state)
          (expr.app
            l
            (expr.app (expr.app `(@prod.mk heap env)
              (expr.app `(@prod.fst heap env) (expr.var 0)))
              (expr.app (expr.app (expr.app `(@override)
                 (expr.app `(@prod.snd heap env) (expr.var 0))) vv) ee)
              ))))
| (expr.app a b) := expr.app (simplify_override_helper a) (simplify_override_helper b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper t) (simplify_override_helper e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helper t) (simplify_override_helper e)
| x := x

meta def simplify_override_helperb : expr → expr
| `(λ st, (absExists (λ (v:%%t), %%e))
          (@prod.mk (@prod.fst st) (override (@prod.snd st) %%vv %%ee))) :=
      (expr.app `(@absExists %%t)
                    (expr.lam "v" binder_info.default t
                       (expr.lam "st" binder_info.default `(imp_state)
                         (expr.app
                           (expr.lower_vars (expr.lift_vars e 0 1) 2 1)
                           (expr.app
                             (expr.app
                               `(@prod.mk heap env)
                               (expr.app `(@prod.fst heap env) (expr.var 0)))
                               (expr.app (expr.app (expr.app `(override)
                                  (expr.app
                                    `(@prod.snd heap env)
                                    (expr.var 0)))
                                  vv) ee))
                          )
                       )))
| (expr.app a b) := expr.app (simplify_override_helperb a) (simplify_override_helperb b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper t) (simplify_override_helperb e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helperb t) (simplify_override_helperb e)
| x := x

--meta def q : ℕ → (ℕ → ℕ)
--| _ := (λ (s:ℕ), s) 3.

--theorem test : 1=2 :=
--begin
--    do {
--      a ← some (q 0),
--      trace "abc",
--      --trace (a.to_raw_format),
--      b ← to_expr (``(λ (sss:ℕ), sss)),
--      trace b.to_raw_fmt,
--      admit
--    }
--end

meta def simplify_override_helper' : expr → expr
| (expr.lam st b stt
      (expr.app
        (expr.app
          (expr.app
            `(absCompose)
            l)
          r)
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app
              (expr.app (expr.app pf hhha) eeea)
              (expr.var 0)))
          (expr.app
            (expr.app
              (expr.app
                `(override)
                (expr.app
                  (expr.app (expr.app ps hhhb) eeeb)
                  (expr.var 0)))
                vv)
              ee)))) :=
  (expr.app (expr.app `(absCompose)
      (expr.lam st b stt
          (expr.app
            l
            (expr.app (expr.app (expr.app (expr.app pm hhh) eee)
              (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
              (expr.app (expr.app (expr.app `(override)
                 (expr.app (expr.app (expr.app ps hhhb) eeeb)
                 (expr.var 0))) vv) ee)
              ))))
      (expr.lam st b stt
          (expr.app
            r
            (expr.app (expr.app (expr.app (expr.app pm hhh) eee)
              (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
              (expr.app (expr.app (expr.app `(override)
                 (expr.app (expr.app (expr.app ps hhhb) eeeb)
                 (expr.var 0))) vv) ee)
              ))))
| (expr.app a b) := expr.app (simplify_override_helper' a) (simplify_override_helper' b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper' t) (simplify_override_helper' e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helper' t) (simplify_override_helper' e)
| x := x

meta def simplify_override_helper2 : expr → expr
| (expr.lam st b stt
    (expr.app (expr.app (expr.app ex ext)
        (expr.lam vvv bb vtt e))
      (expr.app
        (expr.app
          (expr.app (expr.app pm hhh) eee)
          (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
        (expr.app (expr.app (expr.app `(override)
          (expr.app
              (expr.app (expr.app ps hhhb) eeeb)
              (expr.var 0)))
          vv)
        ee)))) := (expr.app (expr.app ex ext)
                    (expr.lam vvv bb vtt
                       (expr.lam st b stt
                         (expr.app
                           (expr.lower_vars (expr.lift_vars e 0 1) 2 1)
                           (expr.app
                             (expr.app
                               (expr.app (expr.app pm hhh) eee)
                                 (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
                               (expr.app (expr.app (expr.app `(override)
                                  (expr.app
                                    (expr.app (expr.app ps hhhb) eeeb)
                                    (expr.var 0)))
                                  vv) ee))
                          )
                       )))

| (expr.app a b) := expr.app (simplify_override_helper2 a) (simplify_override_helper2 b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_helper2 t) (simplify_override_helper2 e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_helper2 t) (simplify_override_helper2 e)
| x := x

meta def replace_varn_helper : ℕ → expr → expr → expr
| n r (expr.var nn) := if n=nn then r else (expr.var nn)
| n r (expr.app a b) := expr.app (replace_varn_helper n r a) (replace_varn_helper n r b)
| n r (expr.lam v b t e) := expr.lam v b (replace_varn_helper (n+1) r t) (replace_varn_helper (n+1) r e)
| n r (expr.pi v b t e) := expr.pi v b (replace_varn_helper n r t) (replace_varn_helper n r e)
| n r x := x

meta def simplify_tree_helper : expr → expr
| (expr.lam st bb stt
    (expr.app
      (expr.app
        (expr.app
          (expr.app
            (expr.app
              tree
              (expr.lam v b t e))
            nn)
          fff)
        fr)
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
            (expr.app (expr.app (expr.app `(override)
              (expr.app
                (expr.app (expr.app ps hhhb) eeeb)
                (expr.var 0)))
            vv)
          ee)))) :=
      (expr.app
        (expr.app
          (expr.app
            (expr.app
              tree
              (expr.lam v b t
               (replace_varn_helper 0
                 (expr.app (expr.app (expr.app `(override)
                   (expr.var 0))
                   vv)
                 ee)
                 (expr.lower_vars e 2 1))
              ))
            (expr.lower_vars nn 1 1))
          (expr.lower_vars fff 1 1))
        (expr.lower_vars fr 1 1))
| (expr.app a b) := expr.app (simplify_tree_helper a) (simplify_tree_helper b)
| (expr.lam v b t e) := expr.lam v b (simplify_tree_helper t) (simplify_tree_helper e)
| (expr.pi v b t e) := expr.pi v b (simplify_tree_helper t) (simplify_tree_helper e)
| x := x

meta def beq_exp : expr → expr → bool
| a b := ff

meta def update_state_reference : ℕ → expr → option expr
| n (expr.app (expr.app (expr.app ps hhh) eee) (expr.var (n1))) :=
      if (n+1)=n1 then some (expr.var n) else none
| n (expr.var n1) :=
  if (n+1)=n1 then none else some (expr.var n1)
| n (expr.app a b) := match update_state_reference n a with
                      | none := none
                      | some aa := match update_state_reference n b with
                                   | none := none
                                   | some bb := (expr.app aa bb)
                                   end
                      end
| n (expr.lam v b t e) := match update_state_reference (n+1) t with
                          | none := none
                          | some aa := match update_state_reference (n+1) e with
                                       | none := none
                                       | some bb := (expr.lam v b aa bb)
                                       end
                          end
| n (expr.pi v b t e) := match update_state_reference (n+1) t with
                         | none := none
                         | some aa := match update_state_reference (n+1) e with
                                      | none := none
                                      | some bb := (expr.pi v b aa bb)
                                      end
                         end
| n x := some x

meta def simplify_override_predicate_helper : expr → expr
| (expr.lam st b stt
      (expr.app
        (expr.app predicate (expr.lam eev bb eet prr))
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
          (expr.app (expr.app (expr.app `(override)
            (expr.app
                (expr.app (expr.app ps hhhb) eeeb)
                (expr.var 0)))
            vv)
          ee)))) :=
    match update_state_reference 0 (replace_varn_helper 0
                                  (expr.app (expr.app (expr.app `(override)
                                    (expr.app
                                      (expr.app (expr.app ps hhhb) eeeb)
                                      (expr.var 0)))
                                      vv) ee)
                                    prr) with
    | some r := (expr.app predicate (expr.lam eev bb eet
                  (expr.lower_vars r 2 1)))
    | none := (expr.lam st b stt
      (expr.app
        (expr.app predicate (expr.lam eev bb eet prr))
        (expr.app
          (expr.app
            (expr.app (expr.app pm hhh) eee)
            (expr.app (expr.app (expr.app pf hhha) eeea) (expr.var 0)))
          (expr.app (expr.app (expr.app `(override)
            (expr.app
                (expr.app (expr.app ps hhhb) eeeb)
                (expr.var 0)))
            vv)
          ee))))
    end

| (expr.app a b) := expr.app (simplify_override_predicate_helper a) (simplify_override_predicate_helper b)
| (expr.lam v b t e) := expr.lam v b (simplify_override_predicate_helper t) (simplify_override_predicate_helper e)
| (expr.pi v b t e) := expr.pi v b (simplify_override_predicate_helper t) (simplify_override_predicate_helper e)
| x := x

meta def xxx : expr → expr
| e := `(absCompose absNone absNone (empty_heap,empty_env)).

meta def simplify_override : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input333333",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_override_helper tgt),
     trace "output prelim",
     trace nt.to_raw_fmt,
     trace "testit3",
     qq ← some (xxx tgt),
     trace qq.to_raw_fmt,
     assert `xxx nt,swap,admit
    }
meta def simplify_override2 : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_override_helperb tgt),
     trace "output",
     trace nt.to_raw_fmt,
     trace "testit112",
     assert `xxx nt,swap,admit
    }

meta def simplify_override_predicate : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input1",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_override_predicate_helper tgt),
     trace "output2",
     trace nt.to_raw_fmt,
     trace "testit",
     assert `xxx nt,swap,admit
    }

meta def simplify_tree : tactic unit :=
do { t ← target,
     tgt ← instantiate_mvars t,
     trace "input1",
     trace tgt.to_raw_fmt,
     nt ← some (simplify_tree_helper tgt),
     trace "output2",
     trace nt.to_raw_fmt,
     trace "testit",
     assert `xxx nt,swap,admit
    }

@[simp] theorem dist_conj (a : absState) (b : absState) (f : imp_state → imp_state) (st : imp_state) :
    (absCompose a b) (f st) = (absCompose (λ st, a (f st)) (λ st, b (f st))) st :=
begin
    admit
end

@[simp] theorem dist_exists_lambda (t:Type) (a: imp_state → Prop) (st : imp_state) (f : imp_state → imp_state):
    absExists (λ (v:t), a) (f st)=absExists (λ (v:t), (λ st, a (f st))) st :=
begin
    admit
end

@[simp] theorem dist_absPredicate (f: env → Prop) (v : ident)
    (e : ℕ) (st : imp_state) :
    absPredicate f (override_state v e st)=
    (absPredicate (λ env, f (override env v e)) st)  :=
begin
    admit
end

@[simp] theorem dist_absTree (r : env → ℕ) (s : ℕ) (f : list ℕ)
                             (st : imp_state) (v : ident) (e : ℕ)
                             (vv : Value) :
    (absTree r s f vv) (override_state v e st)=
    (absTree (λ ee, r (override ee v e)) s f vv) st :=
begin
    admit
end

@[simp] theorem dist_absExistsAbsTree (r : env → ℕ) (s : ℕ) (f : list ℕ)
                             (st : imp_state) (v : ident) (e : ℕ) :
    absExists (absTree r s f) (override_state v e st)=
    absExists (absTree (λ ee, r (override ee v e)) s f) st :=
begin
    admit
end


import Lean
--#eval Lean.versionString

def extendBoolTape (t : Array Bool) : Array Bool :=
  t ++ [false]

def flipTape (n : Nat) (t : Array Bool) (newT : Array Bool) : Array Bool :=
  match n with
  | 0 => newT
  | n+1 => flipTape n t (newT ++ [t[n]])

--syntactic sugar since this are almost always the parameters for flipTape
def flipTapeShort (t : Array Bool) : Array Bool :=
  flipTape t.size t #[]

--k is the rewrite position, newT is the new tape, s is the new value to write and n is tape size
def rewriteHelp (k : Nat) (newT : Array Bool) (s : Bool) (t : Array Bool)  (n : Nat) : Array Bool :=
  match n, k with
  | 0, _ => newT
  | n+1, 0 => rewriteHelp (n+1) (newT ++ [s]) s t n
  | n+1, k+1 => rewriteHelp k (newT ++ [t[n]]) s t n

--s if the new value to be written at spot n in the tape, t is the tape
def rewrite (s : Bool) (t : Array Bool) (n : Nat) : Array Bool :=
  if s = t[n] then t --if they are the same don't do anything, saves computation
  else t.set! n s

def extendBoolTapeLeft (t : Array Bool) : Array Bool :=
  t.insertAt 0 false

structure TM where
  h : Nat
  t : Array Bool
  q : Int
deriving Repr

def makeTM (head : Nat) (tape : Array Bool) (qState : Int) : TM :=
  {h := head, t := tape, q := qState}

structure TMstate where
  q : Int
  s : Bool
  m : Int
deriving Repr

def makeTMstate (qState : Int) (symbol : Bool) (move : Int) : TMstate :=
  {q := qState, s := symbol, m := move}

--#eval makeTMstate 1 true 1

def translateMove (m : Int) (h : Nat) : Nat :=
  match m with
  | 1 => (h+1)
  | -1 => (h-1)
  | _ => h

def checkTapeBorders (t : Array Bool) (h : Nat) : TM :=
  match h, (t.size - h) with
  | 0, _ => makeTM (h+1) (extendBoolTapeLeft t) (-2)
  | _, 1 => makeTM h (extendBoolTape t) (-2)
  | _, _ => makeTM h t (-2)

def stepMoveHelp (tm : TM) (m : Int) : TM :=
  makeTM (translateMove m tm.h) tm.t (-2)

def stepMove (t : Array Bool) (h : Nat) (m : Int) : TM :=
  stepMoveHelp (checkTapeBorders t h) m

def copyTM (tm : TM) : TM :=
  {h := tm.h, t := tm.t, q := tm.q}

--this temp strat assumes that LEAN doesn't use pointers and instead actually stores a copy
--of the data at the "variable" location
--without a doubt the uglieast part of my code, since new variables cannot be created we must create
--one by passing a duplicate of the original inside since we need to fetch information from the old
--TM state while having one for which we can update the values
def inputStep (tm : TM) (tempTm : TM) (TMIcode : (h : Nat) → (t : Array Bool) → (q : Int) → TMstate) : TM :=
  makeTM (stepMove tm.t tm.h (TMIcode tm.h tm.t tm.q).m).h (rewrite (TMIcode tempTm.h tm.t tempTm.q).s (stepMove tm.t tempTm.h (TMIcode tempTm.h tm.t tm.q).m).t tempTm.h) (TMIcode tempTm.h tempTm.t tempTm.q).q
--can i just nest this massive set of calls in smaller functions and remove the temp faff?

def run (n : Nat) (tm : TM) (TMIcode : (h : Nat) → (t : Array Bool) → (q : Int) → TMstate) :=
  match n, tm.q with
  | 0, _ => tm
  | _, -1 => tm
  | n+1, _ => run n (inputStep tm (copyTM tm) TMIcode) TMIcode

--this function just exists to make interfacing with the tm slicker, just input max steps, tape and code
def interface (maxSteps : Nat) (tape : Array Bool) (TMIcode : (h : Nat) → (t : Array Bool) → (q : Int) → TMstate) :=
  (run maxSteps (makeTM 1 tape 0) TMIcode).t

def verifySegment (turingSeg : Bool) (verifierSeg : Bool) (validThusFar : Bool) : Bool :=
  (turingSeg ↔ verifierSeg) ∧ validThusFar
  --match turingSeg, verifierSeg, validThusFar with
  --| true, true, true => true
  --| false, false, true => true
  --| true, false, true => false
  --| false, true, true => false
  --| _, _, false => false

def trimOneEnd (t : Array Bool) (size : Nat) : Array Bool :=
  match size, t[size] with
  | 0, _ => t
  | n+1, false => trimOneEnd (t.eraseIdx (n+1)) (n)
  | n+1, true => t

def trimTapeHelp (t : Array Bool) : Array Bool :=
  trimOneEnd (flipTape t.size t #[]) (t.size-1)

def trimTape (t : Array Bool) : Array Bool :=
  flipTapeShort (trimTapeHelp (trimOneEnd t (t.size-1)))

def testPls := #[false, false, true, true, false, true, false]

--#eval trimTape testPls

def verifyTape (turingTape : Array Bool) (verifierTape : Array Bool) : Bool :=
  trimTape turingTape = trimTape verifierTape
  --match n with
  --| 0 => verifySegment turingTape[0] verifierTape[0] validThusFar --since the leftmost should always be false item zero need not be checked
  --| n+1 => verifyTape n turingTape verifierTape (verifySegment turingTape[n] verifierTape[n] validThusFar)

def tapeToIntHelp (n : Nat) (t : Array Bool) : Nat :=
  match n, t[n] with
  | 0, _ => 0
  | n+1, true => tapeToIntHelp n t + 1
  | n+1, false => tapeToIntHelp n t

def tapeToInt (t : Array Bool) : Nat :=
  tapeToIntHelp (t.size -1) t

def intToTapeHelp (n : Nat) : Array Bool :=
  match n with
  | 0 => #[false]
  | n+1 => (intToTapeHelp n) ++ #[true]

def intToTape (n : Nat) : Array Bool :=
  intToTapeHelp n ++ #[false]

def intToLTapeHelp (n : Nat) : List Bool :=
  match n with
  | 0 => [false]
  | n+1 => true :: (intToLTapeHelp n)

def intToLTape (n : Nat) : List Bool :=
  false :: intToLTapeHelp n

--succ n turing machine
def TMsucc (h : Nat) (t : Array Bool) (q : Int) : TMstate :=
  match t[h], q with
  | true, 0 => makeTMstate 0 true 1
  | false, 0 => makeTMstate (-1) true 1
  | _, _ => makeTMstate (-1) false 0

--addition turing machine
def TMadd (h : Nat) (t : Array Bool) (q : Int) : TMstate :=
  match t[h], q with
  | true, 0 => makeTMstate 0 true 1
  | false, 0 => makeTMstate 1 true 1
  | true, 1 => makeTMstate 1 true 1
  | false, 1 => makeTMstate 2 false (-1)
  | true, 2 => makeTMstate (-1) false 0
  | false, 2 => makeTMstate (-1) false 0 --error
  | _, _ => makeTMstate (-1) false 0

--#eval verifyTape 5 #[false, true, true, false, false] #[false, true, true, false, false] true

def threeTape : Array Bool := #[false, true, true, true, false, false]

def addTape : Array Bool := #[false, true, true, false, true, true, true, false, false, false]

--#eval run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMadd).t 0) TMsucc
--#eval run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMsucc).t 0) TMadd

--#eval verifyTape addTape.size (run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMadd).t 0) TMsucc).t (run 10 (makeTM 0 (run 10 (makeTM 0 addTape 0) TMsucc).t 0) TMadd).t true

--#eval (run 10 (makeTM 0 #[false, true, true, true, false] 0) TMsucc).t
#eval interface 10 addTape TMadd

def stateCountTM (h : Nat) (t : Array Bool) (q : Int) : TMstate :=
  match t[h], q with
  | true, 0 => makeTMstate 0 false 1
  | false, 0 => makeTMstate 1 true 1
  | true, 1 => makeTMstate 1 false 1
  | false, 1 => makeTMstate 2 false 1
  | true, 2 => makeTMstate 2 false 1
  | false, 2 => makeTMstate 3 false 1
  | true, 3 => makeTMstate 3 false 1
  | false, 3 => makeTMstate 4 false 1
  | true, 4 => makeTMstate 4 false 1 --error
  | false, 4 => makeTMstate 5 false 1
  | true, 5 => makeTMstate (-1) true 1
  | false, 5 => makeTMstate 6 false 1
  | true, 6 => makeTMstate 1 false 1
  | false, 6 => makeTMstate 7 false 1
  | true, 7 => makeTMstate 8 true (-1)
  | false, 7 => makeTMstate (-1) false 0 --program end
  | true, 8 => makeTMstate 9 true 1
  | false, 8 => makeTMstate 8 false (-1)
  | true, 9 => makeTMstate (-1) true 0 --error
  | false, 9 => makeTMstate 10 true 1
  | true, 10 => makeTMstate 11 false 1
  | false, 10 => makeTMstate 10 false 1
  | true, 11 => makeTMstate 11 false 1
  | false, 11 => makeTMstate 1 false 1
  | _, _ => makeTMstate (-1) false 0

def succEncoding : Array Bool :=
#[false,
  false, true, false, true, true, false, true, true, true, false, true, false, false,
  true, true, false, true, false, true, false, true, true, false, false, false,
  true, false, true, false, true, false, true, false, true, false, false,
  true, true, false, true, false, true, true, true, false, true, false, false, false, false]

--#eval succEncoding.size

def addEncoding : Array Bool :=
#[false,
  false, true, false, true, true, false, true, true, true, true, true, false, true, false, false,
  true, true, false, true, false, true, false, true, true, false, false, false,
  true, false, true, false, true, false, true, false, true, false, false,
  true, true, false, true, false, true, true, false, true, false, false, false,
  true, true, false, true, false, true, false, true, true, false, true, false, false,
  true, true, false, true, true, false, true, true, true, false, true, true, false, false, false,
  true, true, true, false, true, false, true, true, false, true, true, true, true, true, false, true, true, false, false,
  true, true, false, true, true, false, true, true, true, true, true, false, true, true, false, false, false, false]

#eval addEncoding.size

--#eval (run 419 (makeTM 1 addEncoding 0) stateCountTM).t

def stateCountEncoding : Array Bool :=
#[false, false, true, false, true, false, false, true, true, false, false,
  true, true, false, true, false, true, false, true, false, false, false,
  true, false, true, false, true, false, true, false, true, true, false, false,
  true, true, false, true, false, true, true, false, true, true, false, false, false,
  true, true, false, true, false, true, false, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, false, true, true, false, false, false,
  true, true, true, false, true, false, true, false, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, false, true, false, true, false, true, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, false, true, false, true, false, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, false, true, false, true, true, false, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, true, false, true, true, true, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, true, false, true, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, true, true, false, true, false, true, true, false, true, true, true, true, true, true, true, true, true, true, true, true, true, false, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, true, true, true, true, false, true, false, false, false,
  true, true, true, true, true, true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false, false,
  true, true, true, true, true, true, true, true, true, true, true, false, true, false, true, false, true, true, true, true, true, true, true, true, true, true, true, false, true, true, false, false,
  true, true, false, true, false, true, false, true, true, false, false, false, false]

#eval stateCountEncoding.size

--#eval tapeToInt (interface 4657 stateCountEncoding stateCountTM)
--#eval [false, true, false].get! 2
--#eval [false, true, false]

def zeroTape := #[false, false]

--axiom zero_to_tm : 0 = tapeToInt 3 #[false, false, false, false]

axiom zero_to_tm : intToTape 0 = #[false, false]

theorem tm_to_zero : #[false, false] = intToTape 0 := by
  rw [zero_to_tm]

axiom succ_in_tm (n : Nat) : intToTape (Nat.succ n) = (interface (n+2) (intToTape n) TMsucc)

theorem TMsucc_in_nat (n : Nat) : (interface (n+2) (intToTape n) TMsucc) = intToTape (Nat.succ n) := by
  rw [succ_in_tm]

--axiom TM_succ_evals (n : Nat ): (interface (n+2) (intToTape n) TMsucc) = #[false, true{n times}, false]

#eval tapeToInt #[false, true, true, false]

theorem oneTMrep : intToTape (Nat.succ 0) = (interface (2) (intToTape 0) TMsucc) := by
  rw [succ_in_tm]

theorem one_eq_succ_zero: 1 = Nat.succ 0 := by
  rw [Nat.succ_eq_add_one]

#eval interface 2 #[false, false] TMsucc
#eval intToTape 1

theorem one_to_tape : intToLTape (1) = [false, true, false] := by
  unfold intToLTape
  unfold intToLTapeHelp
  unfold intToLTapeHelp
  simp

def listTapeSucc (t : List Bool) : List Bool :=
  false :: (true :: (t.eraseIdx 0))

#eval listTapeSucc [false, true, true, false]

theorem proof_of_concept : intToLTape (Nat.succ 0) = listTapeSucc [false, false] := by
  rw [Nat.succ_eq_add_one]
  rw [Nat.zero_add]
  unfold intToLTape
  unfold intToLTapeHelp
  unfold intToLTapeHelp
  unfold listTapeSucc
  unfold List.eraseIdx
  simp

--1 = tapeToInt 3 #[false, true, false, false]
--1 = tapeToInt 3

 -- succ_eq_add_one succ n = n + 1


import .lang
import .forget
import .free_ralg
import .fron_ralg
import .add_rules
import .ualg

namespace rules_hom

variables {L0 : lang} {R0 : rules L0} {L1 : lang} {R1 : rules L1}
variables (ι : R0 →# R1)
variables (A : Type*) [ualg R0 A]

include ι
def fron := R1.add (ι.lhom.fron A)

namespace fron

instance : has_app L1 (ι.fron A) := rules.add.has_app R1 _
instance : compat ι.lhom (ι.fron A) := ι.lhom.forget_along _

def univ : A →$[L0] (ι.fron A) :=
  (lang_hom.fron.univ ι.lhom A).comp
  ((rules.add.univ R1 (ι.lhom.fron A)).drop ι.lhom)

variable {A}
def lift {B : Type*} [ualg R1 B] [compat ι.lhom B] (f : A →$[L0] B) :
  ι.fron A →$[L1] B :=
    rules.add.lift R1 $
    lang_hom.fron.lift _ f

theorem univ_comp_lift {B : Type*} [ualg R1 B] [compat ι.lhom B] (f : A →$[L0] B) :
  (univ ι A).comp ((lift ι f).drop ι.lhom) = f := by {ext, refl}

theorem lift_unique {B : Type*} [ualg R1 B] [compat ι.lhom B] (f : A →$[L0] B)
  (g : ι.fron A →$[L1] B) : (univ ι A).comp (g.drop ι.lhom) = f → g = lift ι f :=
begin
  intro hyp,
  apply rules.add.lift_unique,
  apply lang_hom.fron.lift_unique,
  assumption,
end

end fron

end rules_hom


structure LockedType {T : Sort u} (T' : Sort u) (x : T) where
  val : T'
  type_eq : T = T'
  val_eqv : HEq val x

infix:50 " ~= " => HEq

theorem Eq.toHEq {α} {x y : α} (h : x = y) : x ~= y :=
by cases h; constructor

theorem HEq.toEq {α} {x y : α} (h : x ~= y) : x = y :=
by cases h; rfl

namespace Transport

structure EqvTypes (T T' : Sort u) : Prop where
  rfl : T = T'

class EqvTerm {α α' : Sort u} (x : α) (y : α') : Prop where
  rfl : x ~= y

def refl : EqvTypes T T where
  rfl := rfl

def EqvTypes_arrow {α α' : Sort u} {β β' : Sort v}
    (h₀ : EqvTypes α α') (h₁ : EqvTypes β β') :
         EqvTypes (α → β) (α' → β') where
  rfl := by rw [h₀.rfl, h₁.rfl]

def EqvTypes_forall' {α}
  {β : α → Sort u}
  {β' : α → Sort u}
  (h : ∀ (x : α), EqvTypes (β x) (β' x)) :
  EqvTypes (∀ x, β x) (∀ x, β' x) where
    rfl := by
      have h₀ : ∀ x, β x = β' x :=
        λ x => h x |>.rfl
      have h₁ : β = β' := funext h₀
      rw  [h₁]

def EqvTypes_forall {α α'} (h' : EqvTypes.{v} α α')
  {β : α → Sort u}
  {β' : α' → Sort u}
  (h : ∀ (x : α) (y : α'), EqvTerm x y → EqvTypes (β x) (β' y)) :
  EqvTypes (∀ x, β x) (∀ x, β' x) where
    rfl := by
      have := h'.rfl; subst this
      have h₀ : ∀ x, β x = β' x :=
        λ x => h x x ⟨ HEq.rfl ⟩ |>.rfl
      have h₁ : β = β' := funext h₀
      rw  [h₁]

def EqvTerm_app {α α'} {β β'} (f : α → β) (g : α' → β') x y
    (h₀ : EqvTypes α α')
    (h₁ : EqvTypes β β')
    (h₂ : EqvTerm f g)
    (h₃ : EqvTerm x y) :
  EqvTerm (f x) (g y) where
    rfl := by
      have := h₀.rfl; subst this
      have := h₁.rfl; subst this
      have := HEq.toEq h₂.rfl; subst this
      have := HEq.toEq h₃.rfl; subst this
      constructor

def EqvTerm_app' {α α'} {β : α → Type u} {β' : α' → Type u}
    (f : (x : α) → β x) (g : (x : α') → β' x) x y
    (h₀ : EqvTypes α α')
    (h₁ : EqvTerm β β')
    (h₂ : EqvTerm f g)
    (h₃ : EqvTerm x y) :
  EqvTerm (f x) (g y) where
    rfl := by
      have := h₀.rfl; subst this
      have := HEq.toEq h₃.rfl; subst this
      have := HEq.toEq h₁.rfl; subst this
      have := HEq.toEq h₂.rfl; subst this
      constructor

def EqvTypes_of_EqvTerm {α α'} (h : EqvTerm α α') : EqvTypes α α' where
  rfl := by
    have := h.rfl; cases this
    constructor

instance EqvTypes_of_EqvTerm' {α α'} [EqvTerm α α'] : EqvTypes α α' :=
by apply EqvTypes_of_EqvTerm <;> assumption

instance (x : α) : EqvTerm x x where
  rfl := HEq.rfl

def transport α α' (h : EqvTypes α' α) (x : α) : α' :=
cast (EqvTypes.rfl h |>.symm) x

def transport_eq α α' (h : EqvTypes α' α) (x : α) :
  HEq (transport α α' h x) x := by
have h := @EqvTypes.rfl α' α h
subst h
constructor

def mkLockedType (α) {α'} (x : α')
    -- (h : EqvTypes α' α := by prove_transport) :
    (h : EqvTypes α α') :
    LockedType α x where
  val := transport _ _ h x
  type_eq := EqvTypes.rfl h |>.symm
  val_eqv := transport_eq _ _ h _

def EqvTerm.ofEq {x y : α} (h : x = y) : EqvTerm x y where
  rfl:= h.toHEq

def EqvTerm.ofHEq {α β} {x : α} {y : β} (h : x ~= y) :
    EqvTerm x y where
  rfl:= h

end Transport


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Tim Baumann, Stephen Morgan, Scott Morrison

import category_theory.isomorphism
import category_theory.functor_category

open category_theory

namespace category_theory.nat_iso

universes u₁ u₂ v₁ v₂

variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C] {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

def app {F G : C ⥤ D} (α : F ≅ G) (X : C) : F X ≅ G X :=
{ hom := (α : F ⟶ G) X,
  inv := (α.symm : G ⟶ F) X,
  hom_inv_id' := begin rw [← functor.category.comp_app, iso.hom_inv_id], refl, end,
  inv_hom_id' := begin rw [← functor.category.comp_app, iso.inv_hom_id], refl, end }

instance {F G : C ⥤ D} : has_coe_to_fun (F ≅ G) :=
{ F   := λ α, Π X : C, (F X) ≅ (G X),
  coe := λ α, app α }

@[simp] lemma mk_app {F G : C ⥤ D} (hom : F ⟹ G) (inv) (hom_inv_id') (inv_hom_id') (X : C) :
  ({ hom := hom, inv := inv, hom_inv_id' := hom_inv_id', inv_hom_id' := inv_hom_id' } : F ≅ G) X =
  { hom := hom X, inv := inv X,
    hom_inv_id' := congr_fun (congr_arg nat_trans.app hom_inv_id') X,
    inv_hom_id' := congr_fun (congr_arg nat_trans.app inv_hom_id') X } :=
rfl
@[simp] lemma mk_app' {F G : C ⥤ D} (hom : F ⟹ G) (inv) (hom_inv_id') (inv_hom_id') (X : C) :
  (({ hom := hom, inv := inv, hom_inv_id' := hom_inv_id', inv_hom_id' := inv_hom_id' } : F ≅ G) : F ⟹ G) X = hom X :=
rfl

@[simp] lemma comp_app {F G H : C ⥤ D} (α : F ≅ G) (β : G ≅ H) (X : C) :
  ((α ≪≫ β) : F ⟹ H) X = α X ≪≫ β X := rfl

@[simp] lemma hom_eq_coe {F G : C ⥤ D} (α : F ≅ G) (X : C) : α.hom X = (α : F ⟶ G) X := rfl
@[simp] lemma inv_eq_symm_coe {F G : C ⥤ D} (α : F ≅ G) (X : C) : α.inv X = (α.symm : G ⟶ F) X := rfl

variables {F G : C ⥤ D}

instance hom_app_is_iso (α : F ≅ G) (X : C) : is_iso ((α : F ⟶ G) X) :=
{ inv := α.inv X,
  hom_inv_id' := begin dsimp at *, erw [←functor.category.comp_app, iso.hom_inv_id, ←functor.category.id_app] end,
  inv_hom_id' := begin dsimp at *, erw [←functor.category.comp_app, iso.inv_hom_id, ←functor.category.id_app] end }
instance inv_app_is_iso (α : F ≅ G) (X : C) : is_iso ((α.symm : G ⟶ F) X) :=
{ inv := α.hom X,
  hom_inv_id' := begin dsimp at *, erw [is_iso.hom_inv_id] end,
  inv_hom_id' := begin dsimp at *, erw [is_iso.hom_inv_id] end }

variables {X Y : C}
@[simp] lemma naturality_1 (α : F ≅ G) (f : X ⟶ Y) :
  ((α.symm : G ⟶ F) X) ≫ (F.map f) ≫ ((α : F ⟶ G) Y) = G.map f :=
begin erw [nat_trans.naturality, ←category.assoc, is_iso.hom_inv_id, category.id_comp] end
@[simp] lemma naturality_2 (α : F ≅ G) (f : X ⟶ Y) :
  ((α : F ⟶ G) X) ≫ (G.map f) ≫ ((α.symm : G ⟶ F) Y) = F.map f :=
begin erw [nat_trans.naturality, ←category.assoc, is_iso.hom_inv_id, category.id_comp] end

def of_components (app : ∀ X : C, (F X) ≅ (G X))
  (naturality : ∀ {X Y : C} (f : X ⟶ Y), (F.map f) ≫ ((app Y) : F Y ⟶ G Y) = ((app X) : F X ⟶ G X) ≫ (G.map f)) :
  F ≅ G :=
{ hom  := { app := λ X, ((app X) : F X ⟶ G X), },
  inv  :=
  { app := λ X, ((app X).symm : G X ⟶ F X),
    naturality' := λ X Y f,
    begin
      let p := congr_arg (λ f, (app X).inv ≫ (f ≫ (app Y).inv)) (eq.symm (naturality f)),
      dsimp at *,
      simp at *,
      erw [←p, ←category.assoc, is_iso.hom_inv_id, category.id_comp],
    end } }.

@[simp] def of_components.app (app' : ∀ X : C, (F X) ≅ (G X)) (naturality) (X) :
  app (of_components app' naturality) X = app' X :=
by tidy
@[simp] def of_components.hom_app (app : ∀ X : C, (F X) ≅ (G X)) (naturality) (X) :
  ((of_components app naturality) : F ⟹ G) X = app X := rfl
@[simp] def of_components.inv_app (app : ∀ X : C, (F X) ≅ (G X)) (naturality) (X) :
  ((of_components app naturality).symm : G ⟹ F) X = (app X).symm := rfl

end category_theory.nat_iso

namespace category_theory.functor

universes u₁ u₂ v₁ v₂

section
variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C]
          {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
include 𝒞 𝒟

@[simp] def id_comp (F : C ⥤ D) : functor.id C ⋙ F ≅ F :=
{ hom :=
  { app := λ X, 𝟙 (F X) },
  inv :=
  { app := λ X, 𝟙 (F X) }
}
@[simp] def comp_id (F : C ⥤ D) : F ⋙ functor.id D ≅ F :=
{ hom :=
  { app := λ X, 𝟙 (F X) },
  inv :=
  { app := λ X, 𝟙 (F X) }
}

universes u₃ v₃ u₄ v₄

variables {A : Type u₃} [𝒜 : category.{u₃ v₃} A]
          {B : Type u₄} [ℬ : category.{u₄ v₄} B]
include 𝒜 ℬ
variables (F : A ⥤ B) (G : B ⥤ C) (H : C ⥤ D)

@[simp] def assoc : (F ⋙ G) ⋙ H ≅ F ⋙ (G ⋙ H ):=
{ hom :=
  { app := λ X, 𝟙 (H (G (F X))) },
  inv :=
  { app := λ X, 𝟙 (H (G (F X))) }
}

-- When it's time to define monoidal categories and 2-categories,
-- we'll need to add lemmas relating these natural isomorphisms,
-- in particular the pentagon for the associator.
end

section
variables {C : Type u₁} [𝒞 : category.{u₁ v₁} C]
include 𝒞

def ulift_down_up : ulift_down.{u₁ v₁ u₂} C ⋙ ulift_up C ≅ functor.id (ulift.{u₂} C) :=
{ hom := { app := λ X, @category.id (ulift.{u₂} C) _ X },
  inv := { app := λ X, @category.id (ulift.{u₂} C) _ X } }

def ulift_up_down : ulift_up.{u₁ v₁ u₂} C ⋙ ulift_down C ≅ functor.id C :=
{ hom := { app := λ X, 𝟙 X },
  inv := { app := λ X, 𝟙 X } }

end

end category_theory.functor


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.data.option.basic
import init.meta.tactic
import init.control.lawful

universes u v

instance : is_lawful_monad option :=
{ id_map := λ α x, option.rec rfl (λ x, rfl) x,
  pure_bind := λ α β x f, rfl,
  bind_assoc := λ α β γ x f g, option.rec rfl (λ x, rfl) x }

lemma option.eq_of_eq_some {α : Type u} : Π {x y : option α}, (∀z, x = some z ↔ y = some z) → x = y
| none     none     h := rfl
| none     (some z) h := option.no_confusion ((h z).2 rfl)
| (some z) none     h := option.no_confusion ((h z).1 rfl)
| (some z) (some w) h := option.no_confusion ((h w).2 rfl) (congr_arg some)

lemma option.eq_some_of_is_some {α : Type u} : Π {o : option α} (h : option.is_some o), o = some (option.get h)
| (some x) h := rfl

lemma option.eq_none_of_is_none {α : Type u} : Π {o : option α}, o.is_none → o = none
| none h := rfl


/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis, Mario Carneiro, Gabriel Ebner
-/

import Lean
import Mathlib.Tactic.NormCast.CoeExt
import Mathlib.Tactic.RunCmd

open Lean Meta

namespace Tactic.NormCast

/--
`label` is a type used to classify `norm_cast` lemmas.
* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
inductive Label
  | elim
  | move
  | squash
  deriving DecidableEq, Repr, Inhabited

def getSimpArgs (e : Expr) : MetaM (Array Expr) := do
  match ← mkCongrSimp? e.getAppFn with
  | none => return e.getAppArgs
  | some {argKinds, ..} =>
    let mut args := #[]
    for a in e.getAppArgs, k in argKinds do
      if k matches CongrArgKind.eq then
        args := args.push a
    return args

/-- Count how many coercions are at the top of the expression. -/
partial def countHeadCoes (e : Expr) : MetaM Nat := do
  if let Expr.const fn .. := e.getAppFn then
    if let some info ← getCoeFnInfo? fn then
      if e.getAppNumArgs >= info.numArgs then
        return (← countHeadCoes (e.getArg! info.coercee)) + 1
  return 0

/-- Count how many coercions are inside the expression, including the top ones. -/
partial def countCoes (e : Expr) : MetaM Nat :=
  lambdaTelescope e fun xs e => do
    if let Expr.const fn .. := e.getAppFn then
      if let some info ← getCoeFnInfo? fn then
        if e.getAppNumArgs >= info.numArgs then
          let mut coes := (← countHeadCoes (e.getArg! info.coercee)) + 1
          for i in [info.numArgs:e.getAppNumArgs] do
            coes := coes + (← countCoes (e.getArg! i))
          return coes
    return (← (← getSimpArgs e).mapM countCoes).foldl (·+·) 0

/-- Count how many coercions are inside the expression, excluding the top ones. -/
def countInternalCoes (e : Expr) : MetaM Nat :=
  return (← countCoes e) - (← countHeadCoes e)

/-- Classifies a declaration of type `ty` as a `norm_cast` rule. -/
def classifyType (ty : Expr) : MetaM Label :=
  forallTelescopeReducing ty fun xs ty => do
    let ty ← whnf ty
    let (lhs, rhs) ←
      if ty.isAppOfArity ``Eq 3 then pure (ty.getArg! 1, ty.getArg! 2)
      else if ty.isAppOfArity ``Iff 2 then pure (ty.getArg! 0, ty.getArg! 1)
      else throwError "norm_cast: lemma must be = or ↔, but is{indentExpr ty}"
    let lhsCoes ← countCoes lhs
    if lhsCoes = 0 then throwError "norm_cast: badly shaped lemma, lhs must contain at least one coe{indentExpr lhs}"
    let lhsHeadCoes ← countHeadCoes lhs
    let lhsInternalCoes ← countInternalCoes lhs
    let rhsHeadCoes ← countHeadCoes rhs
    let rhsInternalCoes ← countInternalCoes rhs
    if lhsHeadCoes = 0 then
      return Label.elim
    else if lhsHeadCoes = 1 then do
      unless rhsHeadCoes = 0 do throwError "norm_cast: badly shaped lemma, rhs can't start with coe{indentExpr rhs}"
      if rhsInternalCoes = 0 then
        return Label.squash
      else
        return Label.move
    else if rhsHeadCoes < lhsHeadCoes then do
      return Label.squash
    else do
      throwError "norm_cast: badly shaped shaped squash lemma, rhs must have fewer head coes than lhs{indentExpr ty}"

initialize pushCastExt : SimpExtension ←
  registerSimpAttr `push_cast (extName := `Tactic.NormCast.pushCastExt) $
    "The `push_cast` simp attribute uses `norm_cast` lemmas " ++
    "to move casts toward the leaf nodes of the expression."

/--  The `norm_cast` attribute stores three simp sets. -/
structure NormCastExtension where
  up : SimpExtension
  down : SimpExtension
  squash : SimpExtension
  deriving Inhabited

initialize normCastExt : NormCastExtension ← pure {
  up := ← mkSimpExt `Tactic.NormCast.normCastExt.up
  down := ← mkSimpExt `Tactic.NormCast.normCastExt.down
  squash := ← mkSimpExt `Tactic.NormCast.normCastExt.squash
}

/-- `addElim decl` adds `decl` as an `elim` lemma to the cache. -/
def addElim (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit :=
  addSimpTheorem normCastExt.up decl (post := true) (inv := false) kind prio

/-- `addMove decl` adds `decl` as a `move` lemma to the cache. -/
def addMove (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit := do
  addSimpTheorem pushCastExt decl (post := true) (inv := false) kind prio
  addSimpTheorem normCastExt.up decl (post := true) (inv := true) kind prio
  addSimpTheorem normCastExt.down decl (post := true) (inv := false) kind prio

/-- `addSquash decl` adds `decl` as a `squash` lemma to the cache. -/
def addSquash (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit := do
  addSimpTheorem pushCastExt decl (post := true) (inv := false) kind prio
  addSimpTheorem normCastExt.squash decl (post := true) (inv := false) kind prio
  addSimpTheorem normCastExt.down decl (post := true) (inv := false) kind prio

/-- `addInfer decl` infers the label of `decl` and adds it to the cache.

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
def addInfer (decl : Name)
    (kind := AttributeKind.global) (prio := eval_prio default) : MetaM Unit := do
  let ty := (← getConstInfo decl).type
  match ← classifyType ty with
  | Label.elim => addElim decl kind prio
  | Label.squash => addSquash decl kind prio
  | Label.move => addMove decl kind prio

namespace Attr
syntax normCastLabel := &"elim" <|> &"move" <|> &"squash"

/--
The `norm_cast` attribute should be given to lemmas that describe the
behaviour of a coercion in regard to an operator, a relation, or a particular
function.

It only concerns equality or iff lemmas involving `↑`, `⇑` and `↥`, describing the behavior of
the coercion functions.
It does not apply to the explicit functions that define the coercions.

Examples:
```lean
@[norm_cast] theorem coe_nat_inj' {m n : ℕ} : (↑m : ℤ) = ↑n ↔ m = n

@[norm_cast] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1

@[norm_cast] theorem cast_id : ∀ n : ℚ, ↑n = n

@[norm_cast] theorem coe_nat_add (m n : ℕ) : (↑(m + n) : ℤ) = ↑m + ↑n

@[norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℤ) : α) = n

@[norm_cast] theorem cast_one : ((1 : ℚ) : α) = 1
```

Lemmas tagged with `@[norm_cast]` are classified into three categories: `move`, `elim`, and
`squash`. They are classified roughly as follows:

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes

`norm_cast` uses `move` and `elim` lemmas to factor coercions toward the root of an expression
and to cancel them from both sides of an equation or relation. It uses `squash` lemmas to clean
up the result.

Occasionally you may want to override the automatic classification.
You can do this by giving an optional `elim`, `move`, or `squash` parameter to the attribute.

```lean
@[simp, norm_cast elim] lemma nat_cast_re (n : ℕ) : (n : ℂ).re = n := by
  rw [← of_real_nat_cast, of_real_re]
```

Don't do this unless you understand what you are doing.

A full description of the tactic, and the use of each lemma category, can be found at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
syntax (name := normCast) "norm_cast" (ppSpace normCastLabel)? (ppSpace num)? : attr
end Attr

initialize registerBuiltinAttribute {
  name := `normCast
  descr := "attribute for norm_cast"
  add := fun decl stx kind => MetaM.run' do
    let `(attr| norm_cast $[$label:normCastLabel]? $[$prio]?) := stx | unreachable!
    let prio := (prio.bind Syntax.isNatLit?).getD (eval_prio default)
    match label.bind Syntax.isStrLit? with
    | "elim" => addElim decl kind prio
    | "move" => addMove decl kind prio
    | "squash" => addSquash decl kind prio
    | none => addInfer decl kind prio
    | _ => unreachable!
}