Theory TAO_1_Embedding

theory TAO_1_Embedding
imports Main

section‹Representation Layer›


typedecl i ― ‹possible worlds›
typedecl j ― ‹states›

consts dw :: i ― ‹actual world›
consts dj :: j ― ‹actual state›

typedecl ω ― ‹ordinary objects›
typedecl σ ― ‹special urelements›
datatype υ = ωυ ω | συ σ ― ‹urelements›

subsection‹Derived Types›

typedef 𝗈 = "UNIV::(jibool) set"
  morphisms eval𝗈 make𝗈 .. ― ‹truth values›

type_synonym Π0 = 𝗈 ― ‹zero place relations›
typedef Π1 = "UNIV::(υjibool) set"
  morphisms evalΠ1 makeΠ1 .. ― ‹one place relations›
typedef Π2 = "UNIV::(υυjibool) set"
  morphisms evalΠ2 makeΠ2 .. ― ‹two place relations›
typedef Π3 = "UNIV::(υυυjibool) set"
  morphisms evalΠ3 makeΠ3 .. ― ‹three place relations›

type_synonym α = "Π1 set" ― ‹abstract objects›

datatype ν = ων ω | αν α ― ‹individuals›

typedef κ = "UNIV::(ν option) set"
  morphisms evalκ makeκ .. ― ‹individual terms›

setup_lifting type_definition_𝗈
setup_lifting type_definition_κ
setup_lifting type_definition_Π1
setup_lifting type_definition_Π2
setup_lifting type_definition_Π3

subsection‹Individual Terms and Definite Descriptions›

lift_definition νκ :: "νκ" ("_P" [90] 90) is Some .
lift_definition proper :: "κbool" is "(≠) None" .
lift_definition rep :: "κν" is the .

lift_definition that::"(ν𝗈)κ" (binder "ι" [8] 9) is
  "λ φ . if (∃! x . (φ x) dj dw)
         then Some (THE x . (φ x) dj dw)
         else None" .

subsection‹Mapping from Individuals to Urelements›

consts ασ :: "ασ"
axiomatization where ασ_surj: "surj ασ"
definition νυ :: "νυ" where "νυ  case_ν ωυ (συ  ασ)"

subsection‹Exemplification of n-place-Relations.›

lift_definition exe0::"Π0𝗈" ("_") is id .
lift_definition exe1::"Π1κ𝗈" ("_,_") is
  "λ F x s w . (proper x)  F (νυ (rep x)) s w" .
lift_definition exe2::"Π2κκ𝗈" ("_,_,_") is
  "λ F x y s w . (proper x)  (proper y) 
     F (νυ (rep x)) (νυ (rep y)) s w" .
lift_definition exe3::"Π3κκκ𝗈" ("_,_,_,_") is
"λ F x y z s w . (proper x)  (proper y)  (proper z) 
   F (νυ (rep x)) (νυ (rep y)) (νυ (rep z)) s w" .


lift_definition enc :: "κΠ1𝗈" ("_,_") is
  "λ x F s w . (proper x)  case_ν (λ ω . False) (λ α . F  α) (rep x)" .

subsection‹Connectives and Quantifiers›

consts I_NOT :: "j(ibool)ibool"
consts I_IMPL :: "j(ibool)(ibool)(ibool)"

lift_definition not :: "𝗈𝗈" ("¬_" [54] 70) is
  "λ p s w . s = dj  ¬p dj w  s  dj  (I_NOT s (p s) w)" .
lift_definition impl :: "𝗈𝗈𝗈" (infixl "" 51) is
  "λ p q s w . s = dj  (p dj w  q dj w)  s  dj  (I_IMPL s (p s) (q s) w)" .
lift_definition forallν :: "(ν𝗈)𝗈" (binder "ν" [8] 9) is
  "λ φ s w .  x :: ν . (φ x) s w" .
lift_definition forall0 :: "(Π0𝗈)𝗈" (binder "0" [8] 9) is
  "λ φ s w .  x :: Π0 . (φ x) s w" .
lift_definition forall1 :: "(Π1𝗈)𝗈" (binder "1" [8] 9) is
  "λ φ s w .  x :: Π1  . (φ x) s w" .
lift_definition forall2 :: "(Π2𝗈)𝗈" (binder "2" [8] 9) is
  "λ φ s w .  x :: Π2  . (φ x) s w" .
lift_definition forall3 :: "(Π3𝗈)𝗈" (binder "3" [8] 9) is
  "λ φ s w .  x :: Π3  . (φ x) s w" .
lift_definition forall𝗈 :: "(𝗈𝗈)𝗈" (binder "𝗈" [8] 9) is
  "λ φ s w .  x :: 𝗈  . (φ x) s w" .
lift_definition box :: "𝗈𝗈" ("_" [62] 63) is
  "λ p s w .  v . p s v" .
lift_definition actual :: "𝗈𝗈" ("𝒜_" [64] 65) is
  "λ p s w . p s dw" .

  The connectives behave classically if evaluated for the actual state @{term "dj"},
  whereas their behavior is governed by uninterpreted constants for any
  other state.

subsection‹Lambda Expressions›

  Lambda expressions have to convert maps from individuals to propositions to
  relations that are represented by maps from urelements to truth values.

lift_definition lambdabinder0 :: "𝗈Π0" ("λ0") is id .
lift_definition lambdabinder1 :: "(ν𝗈)Π1" (binder "λ" [8] 9) is
  "λ φ u s w .  x . νυ x = u  φ x s w" .
lift_definition lambdabinder2 :: "(νν𝗈)Π2" ("λ2") is
  "λ φ u v s w .  x y . νυ x = u  νυ y = v  φ x y s w" .
lift_definition lambdabinder3 :: "(ννν𝗈)Π3" ("λ3") is
  "λ φ u v r s w .  x y z . νυ x = u  νυ y = v  νυ z = r  φ x y z s w" .

subsection‹Proper Maps›

  The embedding introduces the notion of \emph{proper} maps from
  individual terms to propositions.

  Such a map is proper if and only if for all proper individual terms its truth evaluation in the
  actual state only depends on the urelements corresponding to the individuals the terms denote.

  Proper maps are exactly those maps that - when used as matrix of a lambda-expression - unconditionally
  allow beta-reduction.

lift_definition IsProperInX :: "(κ𝗈)bool" is
  "λ φ .  x v . ( a . νυ a = νυ x  (φ (aP) dj v)) = (φ (xP) dj v)" .
lift_definition IsProperInXY :: "(κκ𝗈)bool" is
  "λ φ .  x y v . ( a b . νυ a = νυ x  νυ b = νυ y
                     (φ (aP) (bP) dj v)) = (φ (xP) (yP) dj v)" .
lift_definition IsProperInXYZ :: "(κκκ𝗈)bool" is
  "λ φ .  x y z v . ( a b c . νυ a = νυ x  νυ b = νυ y  νυ c = νυ z
                       (φ (aP) (bP) (cP) dj v)) = (φ (xP) (yP) (zP) dj v)" .


lift_definition valid_in :: "i𝗈bool" (infixl "" 5) is
  "λ v φ . φ dj v" .

  A formula is considered semantically valid for a possible world,
  if it evaluates to @{term "True"} for the actual state @{term "dj"}
  and the given possible world.


consts ConcreteInWorld :: "ωibool"

abbreviation (input) OrdinaryObjectsPossiblyConcrete where
  "OrdinaryObjectsPossiblyConcrete   x .  v . ConcreteInWorld x v"
abbreviation (input) PossiblyContingentObjectExists where
  "PossiblyContingentObjectExists   x v . ConcreteInWorld x v
                                         ( w . ¬ ConcreteInWorld x w)"
abbreviation (input) PossiblyNoContingentObjectExists where
  "PossiblyNoContingentObjectExists   w .  x . ConcreteInWorld x w
                                         ( v . ConcreteInWorld x v)"
axiomatization where
  and PossiblyContingentObjectExistsAxiom:
  and PossiblyNoContingentObjectExistsAxiom:

  Care has to be taken that the defined notion of concreteness
  coincides with the meta-logical distinction between
  abstract objects and ordinary objects. Furthermore the axioms about
  concreteness have to be satisfied. This is achieved by introducing an
  uninterpreted constant @{term "ConcreteInWorld"} that determines whether
  an ordinary object is concrete in a given possible world. This constant is
  axiomatized, such that all ordinary objects are possibly concrete, contingent
  objects possibly exist and possibly no contingent objects exist.

lift_definition Concrete::"Π1" ("E!") is
  "λ u s w . case u of ωυ x  ConcreteInWorld x w | _  False" .

  Concreteness of ordinary objects is now defined using this
  axiomatized uninterpreted constant. Abstract objects on the other
  hand are never concrete.

subsection‹Collection of Meta-Definitions›

named_theorems meta_defs

declare not_def[meta_defs] impl_def[meta_defs] forallν_def[meta_defs]
        forall0_def[meta_defs] forall1_def[meta_defs]
        forall2_def[meta_defs] forall3_def[meta_defs] forall𝗈_def[meta_defs]
        box_def[meta_defs] actual_def[meta_defs] that_def[meta_defs]
        lambdabinder0_def[meta_defs] lambdabinder1_def[meta_defs]
        lambdabinder2_def[meta_defs] lambdabinder3_def[meta_defs]
        exe0_def[meta_defs] exe1_def[meta_defs] exe2_def[meta_defs]
        exe3_def[meta_defs] enc_def[meta_defs] inv_def[meta_defs]
        that_def[meta_defs] valid_in_def[meta_defs] Concrete_def[meta_defs]

declare [[smt_solver = cvc4]]
declare [[simp_depth_limit = 10]] (* prevent the simplifier from running forever *)
declare [[unify_search_bound = 40]] (* prevent unification bound errors *)

subsection‹Auxiliary Lemmata›
named_theorems meta_aux

declare makeκ_inverse[meta_aux] evalκ_inverse[meta_aux]
        make𝗈_inverse[meta_aux] eval𝗈_inverse[meta_aux]
        makeΠ1_inverse[meta_aux] evalΠ1_inverse[meta_aux]
        makeΠ2_inverse[meta_aux] evalΠ2_inverse[meta_aux]
        makeΠ3_inverse[meta_aux] evalΠ3_inverse[meta_aux]
lemma νυ_ων_is_ωυ[meta_aux]: "νυ (ων x) = ωυ x" by (simp add: νυ_def)
lemma rep_proper_id[meta_aux]: "rep (xP) = x"
  by (simp add: meta_aux νκ_def rep_def)
lemma νκ_proper[meta_aux]: "proper (xP)"
  by (simp add: meta_aux νκ_def proper_def)
lemma no_αω[meta_aux]: "¬(νυ (αν x) = ωυ y)" by (simp add: νυ_def)
lemma no_σω[meta_aux]: "¬(συ x = ωυ y)" by blast
lemma νυ_surj[meta_aux]: "surj νυ"
  using ασ_surj unfolding νυ_def surj_def
  by (metis ν.simps(5) ν.simps(6) υ.exhaust comp_apply)
lemma lambdaΠ1_aux[meta_aux]:
  "makeΠ1 (λu s w. x. νυ x = u  evalΠ1 F (νυ x) s w) = F"
  proof -
    have " u s w φ . ( x . νυ x = u  φ (νυ x) (s::j) (w::i))  φ u s w"
      using νυ_surj unfolding surj_def by metis
    thus ?thesis apply transfer by simp
lemma lambdaΠ2_aux[meta_aux]:
  "makeΠ2 (λu v s w. x . νυ x = u  ( y . νυ y = v  evalΠ2 F (νυ x) (νυ y) s w)) = F"
  proof -
    have " u v (s ::j) (w::i) φ .
      ( x . νυ x = u  ( y . νυ y = v  φ (νυ x) (νυ y) s w))
       φ u v s w"
      using νυ_surj unfolding surj_def by metis
    thus ?thesis apply transfer by simp
lemma lambdaΠ3_aux[meta_aux]:
  "makeΠ3 (λu v r s w. x. νυ x = u  (y. νυ y = v 
   (z. νυ z = r  evalΠ3 F (νυ x) (νυ y) (νυ z) s w))) = F"
  proof -
    have " u v r (s::j) (w::i) φ . x. νυ x = u  (y. νυ y = v
           (z. νυ z = r  φ (νυ x) (νυ y) (νυ z) s w)) = φ u v r s w"
      using νυ_surj unfolding surj_def by metis
    thus ?thesis apply transfer apply (rule ext)+ by metis