theory Mereotopology
imports Mereology
begin

text {*This is a presentation in Isabelle/HOL of Mereotopology. The presentation is based on ``Parts
and Places'' by Roberto Casati and Achille Varzi @{cite "casati_parts_1999"}, as well as Varzi's
``Parts, Wholes and Part-Whole Relations: The Prospects of Mereotopology'' @{cite "varzi_parts_1996"}. *}

text {* Please note that this is an extremely ROUGH DRAFT. *}

text{* In this file we will take a closer look at the idea of ``an extension that would take us beyond
the prospects of a pure theory of Parthood to deliver a theory of parts and wholes'' @{cite "casati_parts_1999"} p.   *}

section {* Theories *}

subsection {* Ground Topology *}

text {* Ground Topology (T) introduces Connectedness (C) as  a primitive relation (just like the
Parthood relation in Mereology) between individuals. It is assumed to be both reflexive and symmetric
but not transitive" @{cite "casati_parts_1999"}, p. 52. *}

text {* By connection here we mean a physical type of contact between two individuals. For example my
 hand is connected to my body and India is connected to Pakistan. *}

locale T =
 fixes C :: "i ⇒ i ⇒ bool" ("C")--"connectedness"
 assumes connection_reflexivity: "C x x" -- "reflexivity of connectedness "
 and connection_symmetry: "C x y ⟶ C y x" -- "symmetry of connectedness"

begin

text {* By saying x is enclosed in y, we mean that if anything is connected to x then that thing will
also be connected to y. For example my stomach is enclosed in my body since everything that is connected
to my stomach, is also connected to my body. *}

definition E :: "i ⇒ i ⇒ bool" ("E") --"Enclosure"
  where "E x y ≡ ∀z. C z x ⟶ C z y"

text {* The Enclosure relation is reflexive and transitive but not symmetric. *}

lemma enclosure_reflexivity: "E x x"
  by (simp add: E_def)

lemma enclosure_transitivity: "E x y ⟶ E y z ⟶ E x z "
  by (simp add: E_def)

text {* We assume here that the relation of connectedness is "extensional". By the term "extensional"
we mean that if two things are connected to all of the same things, then they are identical, viz: *}

lemma connection_extensional: "(∀ z. C x z ⟷ C y z) ⟷ x = y" nitpick oops

text {* But that is not a theorem in "T"- nitpick finds a counterexample here. *}

text {* According to Casati and Varzi, ``If C is extensional then E is also antisymmetric relation'' @{cite "casati_parts_1999"} p.53. *}

lemma
  assumes connection_extensional: "(∀ z. C x z ⟷ C y z) ⟷ x = y"
  shows enclousre_antisymmetry: "E x y ∧ E y x ⟶ x = y"
  using E_def connection_extensional connection_symmetry by blast

text {* As we can see by assuming C is extensional, we get the antisymmetry of the enclosure relation right. *}

end

subsection{* Ground Mereotopology *}

text{* Ground Mereotopology (MT) involves the connection between Mereology and Topology. The axiom
of monotonicity tells us that if "x is part of y" then "x is always enclosed in y". That seems obvious
from what I have mentioned about the enclosure relation before. So we can assume this here and we
call this the ``monotonicity'' axiom. *}

locale MT = ground_mereology + T +
  assumes monotonicity: "P x y ⟶ E x y"

begin

text {* The following theorem could be used as an alternative axiom to monotonicity @{cite "casati_parts_1999"} p. 54: *}

lemma "P x y ⟶ (∀z. C x z ⟶ C z y)"
  using E_def monotonicity connection_symmetry by blast

text {* If x is part of y then x is enclosed in y, according to the monotonicity axiom. If x is enclosed
in y then everything that is connected to x will also be connected to y, according to the definition
of the enclosure relation. *}

lemma connection_extensional: "(∀ z. C x z ⟷ C y z) ⟷ x = y" nitpick oops

  text {* Monotonicity implies that the mereological overlap is a form of connection; if x and y overlap
then they are also connected. *}

lemma overlap_implies_connection: "O x y ⟶ C x y"
  using E_def monotonicity O_def connection_symmetry connection_reflexivity by blast

text {* But the converse fails. *}

lemma  "C x y ⟶ O x y" nitpick oops

text {* This leads us to define external connection, where x is externally connected to y only
when x and y are connected but they do not have a common part or they do not overlap. *}

definition EC :: "i => i⇒ bool" ("EC") -- "external connection"
  where "EC x y ≡ C x y ∧ D x y"

text {* On the intended interpretation, this relation holds between things that barely "touch" or
"abut" each other. It is symmetric and irreflexive, but not transitive.  *}

lemma external_connection_irreflexive: "¬ EC x x"
  by (simp add: EC_def D_irreflexive)

lemma external_connection_symmetric: "EC x y ⟶ EC y x"
  using EC_def connection_symmetry D_symmetry by blast

lemma external_connection_transitive: "EC x y ⟶ EC y z ⟶ EC x z" nitpick [user_axioms] oops

text{* ``Further mereotopological predicates can be defined as follows'' @{cite "casati_parts_1999"} p. 55. *}

definition IP :: "i => i⇒ bool" ("IP") -- "internal part -- part of y connected only to overlappers of y"
  where
"IP x y ≡ P x y ∧ (∀z. C z x ⟶ O z y)"

text {* For example, Ethiopia is an internal part of Africa because every country connected to
Ethiopia overlaps Africa. But Egypt is not an internal part of Africa, because Egypt is connected
to Israel, and Israel does not overlap Africa. *}

text {* Internal parthood is neither reflexive nor irreflexive, but it is antisymmetric and transitive:
 *}

lemma internal_part_reflexive: "IP x x" nitpick [user_axioms] oops

lemma internal_part_irreflexive: "¬ IP x x" nitpick [user_axioms] oops

lemma internal_part_antisymmetry: "IP x y ⟶ IP y x ⟶ x = y"
  by (simp add: IP_def P_antisymmetry)

lemma internal_part_transitivity: "IP x y ⟶ IP y z ⟶ IP x z"
  using IP_def P_transitivity overlap_implies_connection by blast

definition TP :: "i ⇒ i ⇒ bool" ("TP") -- "Tangential part -- part but not internal part"
  where "TP x y ≡ P x y ∧ ¬ IP x y"

text {* As long as something has a tangential part, it is a tangential part of itself: *}

lemma tangential_part_reflexivity: "∃ y. TP y x ⟶ TP x x" by simp

text {* Likewise, tangential parthood is antisymmetric, but not transitive: *}

lemma tangential_part_antisymmetry: "TP x y ⟶ TP y x ⟶ x = y"
  by (simp add: P_antisymmetry TP_def)

lemma tangential_part_transitivity: "TP x y ⟶ TP y z ⟶ TP x z" nitpick [user_axioms] oops

definition IO :: "i ⇒ i ⇒ bool" ("IO") -- "Internal overlap"
  where
"IO x y ≡ ∃ z. IP z x ∧ IP z y"

text {* If x and y overlap internally, there exist a thing which is an internal part of x as well as
of y. *}

text {* Internal overlap is both reflexive and symmetric; but not transitive. *}

lemma IO_reflexivity: "∃ y. IO y x ⟶ IO x x"
  by simp
lemma IO_symmetric: "IO x y ⟶ IO y x"
  using IO_def by blast
lemma IO_transitive: "IO x y ⟶ IO y z ⟶ IO x z" nitpick [user_axioms] oops

definition TO :: "i ⇒ i ⇒ bool" ("TO") -- "Tangential overlap -- overlap but not internal overlap"
  where
"TO x y ≡ O x y ∧ ¬IO x y"

lemma TO_reflexivity: "∃ y. TO y x ⟶ TO x x"
  by simp
lemma TO_symmetric: "TO x y ⟶ TO y x"
  using IO_symmetric TO_def O_symmetry by blast

definition IU :: "i⇒i⇒ bool" ("IU") -- "Internal underlap"
  where "IU x y ≡ ∃z. IP x z ∧ IP y z"

definition TU :: "i⇒i⇒bool" ("TU") -- "Tangentially underlap"
  where "TU x y ≡ U x y ∧ ¬ IU x y"

text{* ``More generally, For each mereological predicate R we can define corresponding
 mereotopological predicates replacing IR and TR by substituting IP and TP (respectively)
for each occurrence of P in the definiens'' @{cite "casati_parts_1999" } P-55,4.2. For example: *}

definition IPP :: "i => i⇒ bool" ("IPP") -- "Internal proper part"
  where "IPP x y ≡ IP x y ∧ ¬(IP y x)"

definition TPP :: "i⇒i⇒bool" ("TPP") -- "Tangential proper part"
  where
"TPP x y ≡ TP x y ∧ ¬( TP y x)"

text{* Below we define the predicate for self connectedness that makes the difference between solid
wholes (such as table or a cup) and scattered wholes (such as a bikini or a broken glass; to define self-
connectedness we say that x is self-connected if and only if any two parts that make the whole of x are connected
to each other: *}

definition SC :: "i ⇒ bool" ("SC") -- "Self-connectedness"
  where
"SC x ≡ ∀ y.∀ z.(∀ w. O w x ⟷ O w y ∨ O w z) ⟶ C y z"

text {* This definition basically says that x is self-connected if and only if if x is a fusion of y and z,
then y and z are connected. *}

end

section {* Closed Mereotopology *}

locale CMT = closure_mereology + MT +
  assumes connection_implies_underlap: "C x y ⟶ U x y "

text {* Casati and Varzi say we get the following theorem @{cite "casati_parts_1999"} p. 58. And
we should. If x and y are connected, then according to the axiom they underlap. So then according to
sum closure they have a sum. And since x and y are connected, and self-connected, it seems as if this
sum should be self-connected too: *}

lemma (in CMT) SCC: "(C x y ∧ SC x ∧ SC y) ⟶ (∃z. SC z ∧ (∀ w. O w z ⟷ O w x ∨ O w y))" nitpick [user_axioms] oops

text {* The failure of SCC in Closed Minimal Mereotopology seems to be a minor error in Casati and Varzi. *}

locale CEMT = closed_extensional_mereology + CMT

section {* Classical Extensional Mereotopology *}

locale GEMT = classical_extensional_mereology + MT

begin

text {* The problem with Casati and Varzi's parts began to arise when we realized that the only certainty
 about the connectedness relation is that they underlap. Since we have a universal entity which
 underlaps everything, this axiom does not seem to imply anything. Although one of the main aims
 of Mereotopological theory is to tell exactly what difference should be kept between the relation
 of connection and overlap or how should they vary, I don't see the connection axiom taking us
 anywhere. *}

lemma C_implies_U: "C x y ⟶ U x y"
  by (simp add: universal_underlap)

text {* As we have assumed the existence of the Universal entity which includes everything, it becomes
true that everything is an internal part of the universe: *}

lemma "∀ x. IP x u"
  by (simp add: IP_def P_implies_O u_character)

text {* Now in GEMT, The definition of self connected is itself simpler -- x is self connected means that
every two entities x can be divided into a sum of are connected. *}

lemma SC_def2:  "SC x ⟷ (∀ y z. x = (y ⊕ z) ⟶ C y z)"
proof
  assume "SC x"
  hence "∀ y z. (∀ w. O w x ⟷ (O w y ∨ O w z)) ⟶ C y z"
    using SC_def by simp
  thus "(∀ y z. x = (y ⊕ z) ⟶ C y z)"
    using sum_character by simp
next
  assume "∀ y z. x = (y ⊕ z) ⟶ C y z"
  have "∀ y z. (∀ w. O w x ⟷ (O w y ∨ O w z)) ⟶ C y z"
  proof fix y
    show "∀ z. (∀ w. O w x ⟷ (O w y ∨ O w z)) ⟶ C y z"
    proof fix z
      show "(∀ w. O w x ⟷ (O w y ∨ O w z)) ⟶ C y z"
      proof
        assume "∀ w. O w x ⟷ (O w y ∨ O w z)"
        with sum_intro have "(y ⊕ z) = x"..
        thus "C y z" using ‹∀y z. x = y ⊕ z ⟶ C y z› by blast
      qed
    qed
  qed
  thus "SC x" using SC_def by simp
qed

text {* If two self-connected entities are connected then the sum of them will also be self-connected *}

lemma connected_self_connected_sum: "(C x y ∧ SC x ∧ SC y) ⟶ SC (x ⊕ y)"
proof
  assume "C x y ∧ SC x ∧ SC y"
  have "∀ v w. (x ⊕ y) = (v ⊕ w) ⟶ C v w"
  proof
    fix v
    show "∀ w. (x ⊕ y) = (v ⊕ w) ⟶ C v w"
    proof
      fix w
      show "(x ⊕ y) = (v ⊕ w) ⟶ C v w"
      proof
        assume "(x ⊕ y) = (v ⊕ w)"
        show "C v w"
        proof (cases)
          assume "O v x ∧ O w x ∨ O v y ∧ O w y"
          thus "C v w"
          proof (rule disjE)
            assume "O v x ∧ O w x"
            hence "P x (v ⊕ w) ⟶  x = ((x ⊗ v) ⊕ (x ⊗ w))"
              by (simp add: ‹O v x ∧ O w x› O_symmetry part_of_sum_is_sum_of_products)
            have "P x (v ⊕ w)"
              by (metis ‹x ⊕ y = v ⊕ w› first_summand_inclusion)
            hence "x = ((x ⊗ v) ⊕ (x ⊗ w))"
              using ‹x ≼ v ⊕ w ⟶ x = x ⊗ v ⊕ x ⊗ w› by auto
            hence "C (x ⊗ v) (x ⊗ w)"
              using SC_def2 ‹C x y ∧ SC x ∧ SC y› by blast
            hence "C v (x ⊗ w)"
              by (metis in_first_factor E_def ‹O v x ∧ O w x› connection_symmetry monotonicity product_commutative)
            thus "C v w"
              by (metis in_first_factor E_def ‹O v x ∧ O w x› monotonicity product_commutative)
          next
            assume "O v y ∧ O w y"
            hence "P y (v ⊕ w) ⟶  y = ((y ⊗ v) ⊕ (y ⊗ w))"
              by (simp add: ‹O v y ∧ O w y› O_symmetry part_of_sum_is_sum_of_products)
            have "P y (v ⊕ w)"
              by (metis ‹x ⊕ y = v ⊕ w› second_summand_inclusion)
            hence "y = ((y ⊗ v) ⊕ (y ⊗ w))"
              using ‹y ≼ v ⊕ w ⟶ y = y ⊗ v ⊕ y ⊗ w› by auto
            hence "C (y ⊗ v) (y ⊗ w)"
              using SC_def2 ‹C x y ∧ SC x ∧ SC y› by blast
            hence "C v (y ⊗ w)"
              by (metis E_def in_first_factor ‹O v y ∧ O w y› connection_symmetry monotonicity product_commutative)
            thus "C v w"
              by (metis E_def in_first_factor ‹O v y ∧ O w y› monotonicity product_commutative)
          qed
        next
          assume "¬ (O v x ∧ O w x ∨ O v y ∧ O w y)"
          hence "x = w ∧ y = v ∨ x = v ∧ y = w"
            using disjoint_summand_identity ‹x ⊕ y = v ⊕ w›
            by (metis D_def P_implies_O sum_commutative second_summand_inclusion summand_part)
          thus "C v w"
            using ‹C x y ∧ SC x ∧ SC y› connection_symmetry by blast
        qed
      qed
    qed
  qed
  thus "SC (x ⊕ y)" using SC_def2 by simp
qed

text {* Another way of stating the above lemma is that if two self connected entities are connected then
there is a connected entity which exactly overlaps them: *}

lemma "(C x y ∧ SC x ∧ SC y) ⟶ (∃ z. SC z ∧ (∀ w. O w z ⟷ O w x ∨ O w y))"
proof
  assume "(C x y ∧ SC x ∧ SC y)"
  with connected_self_connected_sum have "SC (x ⊕ y)"..
  have "∀ w. O w (x ⊕ y) ⟷ O w x ∨ O w y" using sum_character.
  hence "SC (x ⊕ y) ∧ (∀ w. O w (x ⊕ y) ⟷ O w x ∨ O w y)"
    using ‹SC (x ⊕ y)› by simp
  thus "∃ z. SC z ∧ (∀ w. O w z ⟷ O w x ∨ O w y)"
    by blast
qed

text {* Below are some theorems and lemmas which we had to prove for our own convenience to understand
exactly the concept of definite descriptions used for the operators like sum, product, interior,
exterior, and to prove a few more things from them. *}

lemma sum_parts : "∃z. P z (x ⊕ y) ⟶ P z x ∨ P z y"
  using ground_mereology.P_reflexivity ground_mereology_axioms by blast

lemma separation: "O x y ⟶ O x z ⟶ (P x (y ⊕ z) ⟶ ((x ⊗ y) ⊕ (x ⊗ z)) = x)"
  by (simp add: part_of_sum_is_sum_of_products)

lemma identity1 : "((D v x ∧  D v y) ∧ x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y))⟶ w = x ⊕ y"
proof
  assume "(D v x ∧  D v y) ∧ x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y)"
  hence "∀z. O z x ∨ O z y ⟷ O z w ∨ O z v"
    by (metis sum_character)
  hence "∃z. O z x ∧ ¬ O z y ∨ ¬ O z v"
    using ‹(D v x ∧ D v y) ∧ x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y)› by blast
  hence "w = x ⊕ y"
    using D_def ‹(D v x ∧ D v y) ∧ x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y)› ‹∀z. (O z x ∨ O z y) = (O z w ∨ O z v)› ground_mereology.O_reflexivity ground_mereology_axioms by blast
  thus "w = x ⊕ y"
    by blast
qed

lemma identity2 : "((D w x ∧ D w y) ∧ x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y))⟶ v = x ⊕ y"
  using GEMT.identity1 GEMT_axioms mereology.sum_commutative by fastforce

lemma identity3 : "((D v x ∧ D w y) ∧ x ⊕ y = w ⊕ v ∧  ¬ (O v x ∧ O w x ∨ O v y ∧ O w y))⟶ x = w ∧ y = v"
  using disjoint_summand_identity sum_commutative by fastforce

lemma identity4 : "((D w x ∧ D v y) ∧ x ⊕ y = w ⊕ v ∧  ¬ (O v x ∧ O w x ∨ O v y ∧ O w y))⟶ w = y ∧ v = x"
  by (metis GEMT.identity3 GEMT_axioms mereology.sum_commutative)

lemma identity: "x ⊕ y = w ⊕ v ⟶ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y) ⟶ x = w ∧ y = v ∨ x = v ∧ y = w"
proof
  assume i1 : "x ⊕ y = w ⊕ v"
  show "¬ (O v x ∧ O w x ∨ O v y ∧ O w y) ⟶ x = w ∧ y = v ∨ x = v ∧ y = w"
  proof
    assume i2 :  "¬ (O v x ∧ O w x ∨ O v y ∧ O w y)"
      from i1 and i2 have "x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y)" by blast
      hence "∀z. O z x ∨ O z y ⟷ O z w ∨ O z v"
        by (metis sum_character)
      hence I1 : "D v x ∨ D w x ∧ D v y ∨ D w y"
        using D_def i2 by auto
      hence I2 : "(D v x ∧ D v y) ∨ (D v x ∧ D w y) ∨ (D w x ∧ D v y) ∨ (D w x ∧ D w y)"
        using D_def i2 by blast
      hence "(w = x ⊕ y) ∨ (v = x ⊕ y) ∨ (w = y ∧ v = x) ∨ (x = w ∧ y = v)"
        by (smt GEMT.identity1 GEMT_axioms ‹x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y)› identity2 identity3 identity4)
      hence "x = w ∧ y = v ∨ x = v ∧ y = w"
        by (metis D_def ‹∀z. (O z x ∨ O z y) = (O z w ∨ O z v)› ‹x ⊕ y = w ⊕ v ∧ ¬ (O v x ∧ O w x ∨ O v y ∧ O w y)› disjoint_summand_identity ground_mereology.O_reflexivity ground_mereology_axioms sum_commutative)
      thus "x = w ∧ y = v ∨ x = v ∧ y = w"
        by blast
    qed
  qed

definition i :: "(i ⇒ i)" ("❙i")--"interior"
  where "❙i x ≡ σ z. IP z x"

text {* The interior of x is the thing which consists of all and only the internal parts of x. *}

definition e :: "(i⇒i)" ("e") -- "exterior"
  where "e x ≡ ❙i (─ x)"

text {* The exterior of x is the thing which consists of all and only the internal parts of the complement
of x. (A thing is a part of the complement of x if and only if it does not overlap x). *}

definition c :: "i⇒i" ("c")--"closure"
  where
"c x ≡ ─ (e x)"

text {* The closure of x is the complement of exterior of x. *}

definition b :: "i⇒i" ("b")--"boundary"
  where "b x ≡ ─ (❙i x ⊕ e x)"

text {* The boundary of x is consisting everything that is neither in the interior of x nor in the
exterior of x. *}

text{* These integrated operators are partially defined, unless we assume the existence of a null
individual that is part of everything *}

text {* We should note that a boundary has no interior and the universe has no exterior. *}

text {* We noticed with Isabelle/HOL that to prove anything much stated using a definite description we
first must prove that the individual denoted by the description in fact meets that description. *}

lemma interior_fusion: "(∃ y. IP y x) ⟶ (∃ v. ∀ y. O y v ⟷ (∃ z. IP z x ∧ O z y))" using fusion.

lemma interior_intro: "(∀ y. O y a ⟷ (∃ z. IP z x ∧ O z y)) ⟶ (❙i x) = a"
proof -
  have "(∀ y. O y a ⟷ (∃ z. IP z x ∧ O z y)) ⟶ (σ z. IP z x) = a" using fusion_intro.
  thus ?thesis using i_def by simp
qed

lemma interior_character: "(∃ y. IP y x) ⟶ (∀ y. O y (❙i x) ⟷ (∃ z. IP z x ∧ O z y))"
proof
  assume antecedent: "(∃ y. IP y x)"
  with interior_fusion have "∃ v. ∀ y. O y v ⟷ (∃ z. IP z x ∧ O z y)"..
  then obtain v where v: "∀ y. O y v ⟷ (∃ z. IP z x ∧ O z y)"..
  with interior_intro have "(❙i x) = v"..
  thus "(∀ y. O y (❙i x) ⟷ (∃ z. IP z x ∧ O z y))"
    using v by blast
qed

lemma interior_is_part: "(∃ y. IP y x) ⟶ P (❙i x) x" -- "the interior of an individual is part of it"
proof
  assume "(∃ y. IP y x)"
  with interior_fusion have "∃ v. ∀ y. O y v ⟷ (∃ z. IP z x ∧ O z y)"..
  then obtain a where a: "∀ y. O y a ⟷ (∃ z. IP z x ∧ O z y)"..
  with interior_intro have "(❙i x) = a"..
  thus "P (❙i x) x"
    by (metis IP_def P_iff_all_O_O a O_symmetry)
qed

lemma interior_overlaps: "(∃ y. IP y x) ⟶ O (❙i x) x"
  by (simp add: P_implies_O interior_is_part)
lemma interior_connects:  "(∃ y. IP y x) ⟶ C (❙i x) x"
  using P_implies_O interior_is_part overlap_implies_connection by blast
lemma encloses_interior:  "(∃ y. IP y x) ⟶ E (❙i x) x"
  by (simp add: interior_is_part monotonicity)

lemma exterior_closure: "(∃ y. IP y (─ x)) ⟶ (∃ a. ∀ y. O y a ⟷ (∃ z. IP z (─ x) ∧ O z y))"
  by (simp add: interior_fusion)

lemma exterior_intro: "(∀ y. O y a ⟷ (∃ z. IP z (─ x) ∧ O z y)) ⟶ (e x) = a"
proof
  assume "(∀ y. O y a ⟷ (∃ z. IP z (─ x) ∧ O z y))"
  with interior_intro have "(❙i (─ x)) = a"..
  thus "(e x) = a"
    using e_def by simp
qed

lemma exterior_character: "(∃ y. IP y (─ x)) ⟶ (∀ y. O y (e x) ⟷ (∃ z. IP z (─ x) ∧ O z y))"
  by (simp add: e_def interior_character)

lemma "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ ¬ P (e x) x" --"external of x is not part of x"
  using e_def P_implies_O in_comp_iff_disjoint interior_is_part D_def by fastforce

lemma "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ ¬ P x (e x)" --" x is also not part of external of x"
  by (metis e_def P_implies_O P_iff_all_O_O complements_disjoint interior_is_part D_def)

lemma "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ D x (e x)" --" even x and external of x never ever overlap"
  using D_symmetry complement_character e_def interior_is_part by fastforce

text  {* Since the closure of x is the complement of exterior of x, a thing is a part of the closure of x if and
only if that thing does not overlap the exterior of x. *}

lemma closure_intro:  "(∀ y. P y a ⟷ D y (e x)) ⟶ (c x) = a"
  by (metis D_irreflexive P_antisymmetry P_iff_all_D_D P_reflexivity c_def e_def in_comp_iff_disjoint u_character)

lemma closure_character: "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ (∀ y. P y (c x) ⟷ D y (e x))"
proof
  assume "x ≠ u ∧ (∃y. IP y (─ x))"
    have "∀y. P y (c x) ⟷ D y (e x)"
      by (metis D_def P_implies_O ‹x ≠ u ∧ (∃y. IP y (─ x))› additive_inverse c_def complements_disjoint e_def in_comp_iff_disjoint interior_is_part summand_inclusion)
    hence "∀y. P y (c x) ⟷ D y (e x)"
      by blast
    thus "(∀ y. P y (c x) ⟷ D y (e x))"
      by blast
  qed

  text {* The closure of x contains everything that is not overlapping with the interior of all the things that
do not overlap x *}

lemma closure_closure: "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ (∃ a. ∀ y. P y a ⟷ D y (e x))"
proof
  assume antecedent: "x ≠ u ∧ (∃ y. IP y (─ x))"
  with closure_character have "(∀ y. P y (c x) ⟷ D y (e x))"..
  thus "(∃ a. ∀ y. P y a ⟷ D y (e x))"..
qed

lemma closure_inclusion: "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ P x (c x)"--"x is part of closure of x"
  using closure_character D_symmetry e_def in_comp_iff_disjoint interior_is_part by fastforce

lemma closure_overlap: "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ O x (c x)"--"x and closure of x overlap"
  by (simp add: P_implies_O closure_inclusion)

lemma closure_connection: "x ≠ u ∧ (∃ y. IP y (─ x)) ⟶ C x (c x)"
  by (simp add: closure_overlap overlap_implies_connection)

lemma boundary_closure: "(❙i x ⊕ e x) ≠ u ⟶ x ≠ u ⟶ (∃ z. IP z x) ⟶ (∃ z. IP z (─ x))⟶
 (∃ a. ∀ z. P z a ⟷ D z (❙i x ⊕ e x))"
  using unique_complement by blast

text {* As defined; the boundary of x is the complement of the sum of the interior and exterior of x, every
part of the boundary of x is disjoint with the interior of x and as well as with the exterior of x. *}

lemma boundary_intro : "(∀ w. P w a ⟷ D w (❙i x ⊕ e x)) ⟶ b x = a"
  by (metis D_def P_antisymmetry P_implies_O P_reflexivity b_def in_comp_iff_disjoint u_character)

lemma boundary_character: "(❙i x ⊕ e x) ≠ u ⟶ x ≠ u ⟶ (∃ z. IP z x) ⟶ (∃ z. IP z (─ x)) ⟶
 (∀ z. P z (b x) ⟷ D z (❙i x ⊕ e x))"
  by (simp add: b_def in_comp_iff_disjoint)

text {* In Varzi's "Parts, Wholes and Part-Whole Relations: The Prospects of Mereotopology", Two
different kinds of entities are defined: one is said to be open and the other one is said to be closed. *}

text {* Open entities are said to be the ones which are identical to their interior; x is the entity containing
all and only the internal parts of x. *}

definition OP :: "i ⇒ bool" ("OP")--"open"
  where "OP x ≡ ❙i x = x"

text {* On the other hand, closed entities are defined as the ones which are identical to their closure. *}

definition CL :: "i ⇒ bool" ("CL") -- "closed"
  where "CL x ≡ c x = x"

end

text{* According to Casati and Varzi ``we can get closer to standard topological theories by supplementing the axiom
of symmetry and reflexivity and the monotonicity of connectedness, with the mereologized
analogues of the standard Kuratowski (1922) axioms for topological closure'' @{cite "casati_parts_1999"}, p. 59. *}

text {* The following version of the axioms are from Varzi``Parts, Wholes and Part-Whole Relations: The Prospects
of Mereotopology'' @{cite "varzi_parts_1996"} p. 273: *}

locale GEMTC = GEMT +
  assumes C4: "CL x ∧ CL y ⟶ CL (x ⊕ y)"
  assumes C5: "(∀ x. F x ⟶ Cl x) ⟶ (∃ z. ∀ y. F y ⟶ z ≼ y) ⟶ CL (π z. F z)"

begin

text {* The interior of x is always a part of x. *}

lemma interior_inclusion : "∃ y. IP y x ⟶ P (❙i x) x"
  by (simp add: IP_def)

text {* Interior of interior x is interior of x. *}

lemma interior_idempotence: "∃ y. IP y x ⟶ ❙i (❙i x) = ❙i x"
  by (metis IP_def P_iff_all_O_O interior_character internal_part_antisymmetry O_reflexivity)

text {* The theorem that interior distributes over product is claimed to follow in Casati and Varzi
@{cite "casati_parts_1999"} p. 59; but when I went to prove that I couldn't do it. There might be an error
here but it's probably something I'm missing in the proof so I will just use it as an axiom. *}

lemma interior_distributes_over_product:
 "(∃ z. IP z (x ⊗ y)) ∧ (∃ z. IP z x) ∧ (∃ z. IP z y) ⟶ ❙i (x ⊗ y) = ❙i x ⊗ ❙i y " sorry

text {* The intersection or the product of two open entities will also be an open entity. *}

lemma C4': "OP x ∧ OP y ∧ (∃ z. IP z (x ⊗ y)) ∧ (∃ z. IP z x) ∧ (∃ z. IP z y) ⟶ z = x ⊗ y ⟶ OP z"
proof
  assume "OP x ∧ OP y ∧ (∃ z. IP z (x ⊗ y)) ∧ (∃ z. IP z x) ∧ (∃ z. IP z y)"
  show "z = x ⊗ y ⟶ OP z"
  proof
    assume "z = x ⊗ y"
    with  interior_distributes_over_product have "❙i x ⊗ ❙i y = ❙i (x ⊗ y)"
      by (simp add: ‹OP x ∧ OP y ∧ (∃z. IP z (x ⊗ y)) ∧ (∃z. IP z x) ∧ (∃z. IP z y)›)
    hence "❙i x ⊗ ❙i y = x ⊗ y"
      using GEMT.OP_def GEMT_axioms ‹OP x ∧ OP y ∧ (∃z. IP z (x ⊗ y)) ∧ (∃z. IP z x) ∧ (∃z. IP z y)› by auto
    hence "x ⊗ y = ❙i (x ⊗ y)"
      using ‹❙i x ⊗ ❙i y = ❙i (x ⊗ y)› by auto
    hence " OP (x ⊗ y)"
      using GEMT.OP_def GEMT_axioms by auto
    thus  "OP z "
      by (simp add: ‹z = x ⊗ y›)
  qed
qed

text {* If there is an entity which have only those parts which are parts of both the interior of x
and interior of y, then that entity is the product of the interior of x and the interior of y. *}

lemma p_intro : "(∀z. P a z ⟷ (P z (❙i x) ∧ P z (❙i y))) ⟶ ((❙i x) ⊗ (❙i y)) = a"
  by (metis (full_types) P_antisymmetry P_implies_O complements_disjoint D_def universe_closure u_intro)

text {* Below is just one simple lemma about the product -- if everything a is part of is part of x and y,
then a is the product of x and y. *}

lemma p : "(∀z. P a z ⟷ (P z x ∧ P z y)) ⟶ (x ⊗ y) = a"
  by (metis P_antisymmetry P_implies_O D_def in_comp_iff_disjoint universe_closure)

text {* If there is an entity with an internal part, then if everything that entity is part of
is part of x and y then that entity is the interior of the product of x and y. *}

lemma pi : "(∃w. IP a w ∧ (∀v. P w v ⟷ P v x ∧ P v y) ⟶ a = ❙i (x ⊗ y))"
  by (meson P_antisymmetry P_reflexivity)

text {* There is a thing such that if (x ⊗ y) is an internal part of it, then it is part of x and y. *}

lemma Pi3 : "∃w. IP (x ⊗ y) w ⟶ P w x ∧ P w y"
  using IP_def by blast

text {* The interior of (x ⊗ y) is part of (x ⊗ y). *}

lemma pp : "(∃z. IP z (x ⊗ y)) ⟶ P (❙i (x ⊗ y)) (x ⊗ y)"
  using interior_is_part by auto

text {* One stronger theorem for the connectedness relation is mentioned here -- x and y are connected
if and only if they either overlap or are externally connected. *}

lemma  C_iff_O_orEC: "C x y ⟷ (O x y ∨ EC x y)"
  using EC_def D_def overlap_implies_connection by blast

text {* Casati and Varzi say two things are externally connected if and only if they share only a
boundary. They write two things are connected if and only if, either one's closure overlaps the
 other entity or they overlap.
And they also say if x and y are externally connected then they are connected but their interiors
are not.  *}

text {* In their words, ``two things are(externally) connected if and only if they share (only) a boundary,i.e.,if and
only if the closure of one overlaps the other, or vice versa:'' @{cite "casati_parts_1999"}'p.59. *}

text {* But we haven't been able to prove that: *}

lemma EC_implies_O_c: "x ≠ u ⟶ (∃ z. IP z (─ x)) ⟶ y ≠ u ⟶ (∃ z. IP z (─ y)) ⟶
EC x y ⟶ (O x (c y) ∨ O (c x) y)"
proof
  assume x_isnt_u: "x ≠ u"
  with complement_character have comp_x: "∀ w. (w ≼ ─ x) ⟷ D w x"..
  show "(∃ z. IP z (─ x)) ⟶ y ≠ u ⟶ (∃ z. IP z (─ y)) ⟶  EC x y ⟶ (O x (c y) ∨ O (c x) y)"
  proof
    assume IP_comp_x: "(∃ z. IP z (─ x))"
    with exterior_character have ext_x: "(∀ y. O y (e x) ⟷ (∃ z. IP z (─ x) ∧ O z y))"..
    from x_isnt_u and IP_comp_x have "x ≠ u ∧ (∃ z. IP z (─ x))"..
    with closure_character have cl_x: "(∀ y. (y ≼ c x) ⟷ D y (e x))"..
    show "y ≠ u ⟶ (∃ z. IP z (─ y)) ⟶ EC x y ⟶ (O x (c y) ∨ O (c x) y)"
    proof
      assume y_isnt_u: "y ≠ u"
      with complement_character have comp_y: "∀ w. (w ≼ ─ y) ⟷ D w y"..
      show "(∃ z. IP z (─ y)) ⟶  EC x y ⟶ (O x (c y) ∨ O (c x) y)"
      proof
        assume IP_comp_y: "(∃ z. IP z (─ y))"
        with exterior_character have ext_y: "(∀ v. O v (e y) ⟷ (∃ z. IP z (─ y) ∧ O z v))"..
        from y_isnt_u and IP_comp_y have "y ≠ u ∧ (∃ z. IP z (─ y))"..
        with closure_character have cl_y: "(∀ v. (v ≼ c y) ⟷ D v (e y))"..
        show "EC x y ⟶ (O x (c y) ∨ O (c x) y)"
        proof
          assume "EC x y"
          hence "D x y"
            using EC_def by simp
          hence "y ≼ ─ x" using comp_x
            using D_symmetry by blast
          thus "(O x (c y) ∨ O (c x) y)" using comp_x ext_x cl_x comp_y ext_y cl_y sorry
        qed
      qed
    qed
  qed
qed

lemma "x ≠ u ⟶ (∃ z. IP z (─ x)) ⟶ y ≠ u ⟶ (∃ z. IP z (─ y)) ⟶
C x y ⟷ (O x y ∨ (O x (c y) ∨ O (c x) y))"
proof
  assume x_isnt_u: "x ≠ u"
  with complement_character have comp_x: "∀ w. (w ≼ ─ x) ⟷ D w x"..
  show "(∃ z. IP z (─ x)) ⟶ y ≠ u ⟶ (∃ z. IP z (─ y)) ⟶ C x y ⟷ (O x y ∨ (O x (c y) ∨ O (c x) y))"
  proof
    assume IP_comp_x: "(∃ z. IP z (─ x))"
    with exterior_character have ext_x: "(∀ y. O y (e x) ⟷ (∃ z. IP z (─ x) ∧ O z y))"..
    from x_isnt_u and IP_comp_x have "x ≠ u ∧ (∃ z. IP z (─ x))"..
    with closure_character have cl_x: "(∀ y. (y ≼ c x) ⟷ D y (e x))"..
    show "y ≠ u ⟶ (∃ z. IP z (─ y)) ⟶ C x y ⟷ (O x y ∨ (O x (c y) ∨ O (c x) y))"
    proof
      assume y_isnt_u: "y ≠ u"
      with complement_character have comp_y: "∀ w. (w ≼ ─ y) ⟷ D w y"..
      show "(∃ z. IP z (─ y)) ⟶ C x y ⟷ (O x y ∨ (O x (c y) ∨ O (c x) y))"
      proof
        assume IP_comp_y: "(∃ z. IP z (─ y))"
        with exterior_character have ext_y: "(∀ v. O v (e y) ⟷ (∃ z. IP z (─ y) ∧ O z v))"..
        from y_isnt_u and IP_comp_y have "y ≠ u ∧ (∃ z. IP z (─ y))"..
        with closure_character have cl_y: "(∀ v. (v ≼ c y) ⟷ D v (e y))"..
        show "C x y ⟷ (O x y ∨ (O x (c y) ∨ O (c x) y))"
        proof
          assume "C x y"
          show "O x y ∨ (O x (c y) ∨ O (c x) y)"
          proof
            cases
            assume "O x y"
            thus "O x y ∨ (O x (c y) ∨ O (c x) y)"..
          next assume "¬ O x y"
            hence "EC x y" using EC_def ‹C x y› by blast
            hence "(O x (c y) ∨ O (c x) y)"
              using EC_implies_O_c sorry
            thus "(O x y ∨ (O x (c y) ∨ O (c x) y))"..
          qed
        next
          assume "O x y ∨ (O x (c y) ∨ O (c x) y)"
          thus "C x y"
          proof (rule disjE)
            assume "O x y"
            thus "C x y" by (simp add: overlap_implies_connection)
          next
            assume "(O x (c y) ∨ O (c x) y)"
            thus "C x y"
            proof (rule disjE)
              assume "O x (c y)"
              show "C x y"
              proof cases
                assume "y = u"
                hence "O x y"
                  using y_isnt_u by auto
                thus "C x y" by (simp add: overlap_implies_connection)
              next
                assume "y ≠ u"
                thus "C x y"  sorry
              qed
            next
              assume "O (c x) y"
              show "C x y"
              proof
                cases
                assume "x = u"
                thus "C x y"
                  using x_isnt_u by blast
              next
          assume "x ≠ u"
          thus "C x y"  sorry
        qed
      qed
    qed
  qed
qed
qed
qed
qed

text {* Even after proving a lot of certain things we were still unable to prove these main theorems
in Casati and Varzi @{cite "casati_parts_1999"}. It seems to be a serious error. *}

text {* I think the error occurs because the relation connectedness is not provided with any strong
enough axiom to prove much about it. We also think the following may be a counterexample; Suppose there
are four simple individuals (a simple or an atom is an individual that has no parts other than itself):
a, b, c and d. Suppose a is connected to b, and c is connected to d, and there are no more connections
amongst the four simples. But suppose also that a + b is connected to c + d. (It follows that all the
other complex (non-simple) individuals are connected as well, but that is not important). It follows that
both a and b are interior parts of a + b, and both c and d are interior parts of c + d, so the interior of
a + b is a + b itself, and the interior of c + d is c + d itself. The exterior of a + b is the interior of its complement, which is c + d. The closure
of a + b is the complement of its exterior, so that's just a + b. Likewise, the closure of c + d is
also c + d.*}

text {* It seems to us (but we have not yet verified formally) that this counterexample satisfies all the
axioms of GEMTC, without satisfying the theorems that we could not prove above. *}

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_int_add_ident_right
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

definition(*fun*) zero :: "Integer" where
"zero = P Z"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

fun plus2 :: "Nat => Nat => Nat" where
"plus2 (Z) y = y"
| "plus2 (S z) y = S (plus2 z y)"

fun t2 :: "Nat => Nat => Integer" where
"t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus :: "Integer => Integer => Integer" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o2) = t2 m (plus2 (S Z) o2)"
| "plus (N m2) (P n2) = t2 n2 (plus2 (S Z) m2)"
| "plus (N m2) (N n3) = N (plus2 (plus2 (S Z) m2) n3)"

theorem property0 :
  "(x = (plus x zero))"
  oops

end


(*  Title:      HOL/Library/RBT_Mapping.thy
    Author:     Florian Haftmann and Ondrej Kuncar
*)

section {* Implementation of mappings with Red-Black Trees *}

(*<*)
theory RBT_Mapping
imports RBT Mapping
begin

subsection {* Implementation of mappings *}

context includes rbt.lifting begin
lift_definition Mapping :: "('a\<Colon>linorder, 'b) rbt \<Rightarrow> ('a, 'b) mapping" is RBT.lookup .
end

code_datatype Mapping

context includes rbt.lifting begin

lemma lookup_Mapping [simp, code]:
  "Mapping.lookup (Mapping t) = RBT.lookup t"
   by (transfer fixing: t) rule

lemma empty_Mapping [code]: "Mapping.empty = Mapping RBT.empty"
proof -
  note RBT.empty.transfer[transfer_rule del]
  show ?thesis by transfer simp
qed

lemma is_empty_Mapping [code]:
  "Mapping.is_empty (Mapping t) \<longleftrightarrow> RBT.is_empty t"
  unfolding is_empty_def by (transfer fixing: t) simp

lemma insert_Mapping [code]:
  "Mapping.update k v (Mapping t) = Mapping (RBT.insert k v t)"
  by (transfer fixing: t) simp

lemma delete_Mapping [code]:
  "Mapping.delete k (Mapping t) = Mapping (RBT.delete k t)"
  by (transfer fixing: t) simp

lemma map_entry_Mapping [code]:
  "Mapping.map_entry k f (Mapping t) = Mapping (RBT.map_entry k f t)"
  apply (transfer fixing: t) by (case_tac "RBT.lookup t k") auto

lemma keys_Mapping [code]:
  "Mapping.keys (Mapping t) = set (RBT.keys t)"
by (transfer fixing: t) (simp add: lookup_keys)

lemma ordered_keys_Mapping [code]:
  "Mapping.ordered_keys (Mapping t) = RBT.keys t"
unfolding ordered_keys_def
by (transfer fixing: t) (auto simp add: lookup_keys intro: sorted_distinct_set_unique)

lemma Mapping_size_card_keys: (*FIXME*)
  "Mapping.size m = card (Mapping.keys m)"
unfolding size_def by transfer simp

lemma size_Mapping [code]:
  "Mapping.size (Mapping t) = length (RBT.keys t)"
unfolding size_def
by (transfer fixing: t) (simp add: lookup_keys distinct_card)

context
  notes RBT.bulkload.transfer[transfer_rule del]
begin
  lemma tabulate_Mapping [code]:
    "Mapping.tabulate ks f = Mapping (RBT.bulkload (List.map (\<lambda>k. (k, f k)) ks))"
  by transfer (simp add: map_of_map_restrict)

  lemma bulkload_Mapping [code]:
    "Mapping.bulkload vs = Mapping (RBT.bulkload (List.map (\<lambda>n. (n, vs ! n)) [0..<length vs]))"
  by transfer (simp add: map_of_map_restrict fun_eq_iff)
end

lemma equal_Mapping [code]:
  "HOL.equal (Mapping t1) (Mapping t2) \<longleftrightarrow> RBT.entries t1 = RBT.entries t2"
  by (transfer fixing: t1 t2) (simp add: entries_lookup)

lemma [code nbe]:
  "HOL.equal (x :: (_, _) mapping) x \<longleftrightarrow> True"
  by (fact equal_refl)

end

(*>*)

text {*
  This theory defines abstract red-black trees as an efficient
  representation of finite maps, backed by the implementation
  in @{theory RBT_Impl}.
*}

subsection {* Data type and invariant *}

text {*
  The type @{typ "('k, 'v) RBT_Impl.rbt"} denotes red-black trees with
  keys of type @{typ "'k"} and values of type @{typ "'v"}. To function
  properly, the key type musorted belong to the @{text "linorder"}
  class.

  A value @{term t} of this type is a valid red-black tree if it
  satisfies the invariant @{text "is_rbt t"}.  The abstract type @{typ
  "('k, 'v) rbt"} always obeys this invariant, and for this reason you
  should only use this in our application.  Going back to @{typ "('k,
  'v) RBT_Impl.rbt"} may be necessary in proofs if not yet proven
  properties about the operations must be established.

  The interpretation function @{const "RBT.lookup"} returns the partial
  map represented by a red-black tree:
  @{term_type[display] "RBT.lookup"}

  This function should be used for reasoning about the semantics of the RBT
  operations. Furthermore, it implements the lookup functionality for
  the data structure: It is executable and the lookup is performed in
  $O(\log n)$.
*}

subsection {* Operations *}

text {*
  Currently, the following operations are supported:

  @{term_type [display] "RBT.empty"}
  Returns the empty tree. $O(1)$

  @{term_type [display] "RBT.insert"}
  Updates the map at a given position. $O(\log n)$

  @{term_type [display] "RBT.delete"}
  Deletes a map entry at a given position. $O(\log n)$

  @{term_type [display] "RBT.entries"}
  Return a corresponding key-value list for a tree.

  @{term_type [display] "RBT.bulkload"}
  Builds a tree from a key-value list.

  @{term_type [display] "RBT.map_entry"}
  Maps a single entry in a tree.

  @{term_type [display] "RBT.map"}
  Maps all values in a tree. $O(n)$

  @{term_type [display] "RBT.fold"}
  Folds over all entries in a tree. $O(n)$
*}

subsection {* Invariant preservation *}

text {*
  \noindent
  @{thm Empty_is_rbt}\hfill(@{text "Empty_is_rbt"})

  \noindent
  @{thm rbt_insert_is_rbt}\hfill(@{text "rbt_insert_is_rbt"})

  \noindent
  @{thm rbt_delete_is_rbt}\hfill(@{text "delete_is_rbt"})

  \noindent
  @{thm rbt_bulkload_is_rbt}\hfill(@{text "bulkload_is_rbt"})

  \noindent
  @{thm rbt_map_entry_is_rbt}\hfill(@{text "map_entry_is_rbt"})

  \noindent
  @{thm map_is_rbt}\hfill(@{text "map_is_rbt"})

  \noindent
  @{thm rbt_union_is_rbt}\hfill(@{text "union_is_rbt"})
*}

subsection {* Map Semantics *}

text {*
  \noindent
  \underline{@{text "lookup_empty"}}
  @{thm [display] lookup_empty}
  \vspace{1ex}

  \noindent
  \underline{@{text "lookup_insert"}}
  @{thm [display] lookup_insert}
  \vspace{1ex}

  \noindent
  \underline{@{text "lookup_delete"}}
  @{thm [display] lookup_delete}
  \vspace{1ex}

  \noindent
  \underline{@{text "lookup_bulkload"}}
  @{thm [display] lookup_bulkload}
  \vspace{1ex}

  \noindent
  \underline{@{text "lookup_map"}}
  @{thm [display] lookup_map}
  \vspace{1ex}
*}

end


subsection\<open>GExp Lexorder\<close>

text\<open>This theory defines a lexicographical ordering on guard expressions such that we can build
orderings for transitions. We make use of the previously established orderings on arithmetic
expressions.\<close>

theory
GExp_Lexorder
imports
  "GExp"
  "AExp_Lexorder"
  "HOL-Library.List_Lexorder"
begin

fun height :: "'a gexp \<Rightarrow> nat" where
  "height (Bc _) = 1" |
  "height (Eq a1 a2) = 1 + max (AExp_Lexorder.height a1) (AExp_Lexorder.height a2)" |
  "height (Gt a1 a2) = 1 + max (AExp_Lexorder.height a1) (AExp_Lexorder.height a2)" |
  "height (In v l) = 2 + size l" |
  "height (Nor g1 g2) = 1 + max (height g1) (height g2)"

instantiation gexp :: (linorder) linorder begin
fun less_gexp_aux :: "'a gexp \<Rightarrow> 'a gexp \<Rightarrow> bool"  where
  "less_gexp_aux (Bc b1) (Bc b2) = (b1 < b2)" |
  "less_gexp_aux (Bc b1) _ = True" |

  "less_gexp_aux (Eq e1 e2) (Bc b2) = False" |
  "less_gexp_aux (Eq e1 e2) (Eq e1' e2') = ((e1 < e1') \<or> ((e1 = e1') \<and> (e2 < e2')))" |
  "less_gexp_aux (Eq e1 e2) _ = True" |

  "less_gexp_aux (Gt e1 e2) (Bc b2) = False" |
  "less_gexp_aux (Gt e1 e2) (Eq e1' e2') = False" |
  "less_gexp_aux (Gt e1 e2) (Gt e1' e2') = ((e1 < e1') \<or> ((e1 = e1') \<and> (e2 < e2')))" |
  "less_gexp_aux (Gt e1 e2) _ = True" |

  "less_gexp_aux (In vb vc) (Nor v va) = True" |
  "less_gexp_aux (In vb vc) (In v va) = (vb < v \<or> (vb = v \<and> vc < va))" |
  "less_gexp_aux (In vb vc) _ = False" |

  "less_gexp_aux (Nor g1 g2) (Nor g1' g2') = ((less_gexp_aux g1 g1') \<or> ((g1 = g1') \<and> (less_gexp_aux g2 g2')))" |
  "less_gexp_aux (Nor g1 g2) _ = False"

definition less_gexp :: "'a gexp \<Rightarrow> 'a gexp \<Rightarrow> bool" where
  "less_gexp a1 a2 = (
    let
      h1 = height a1;
      h2 = height a2
    in
    if h1 = h2 then
      less_gexp_aux a1 a2
    else
      h1 < h2
  )"

declare less_gexp_def [simp]

definition less_eq_gexp :: "'a gexp \<Rightarrow> 'a gexp \<Rightarrow> bool" where
  "less_eq_gexp e1 e2 \<equiv> (e1 < e2) \<or> (e1 = e2)"

lemma less_gexp_aux_antisym: "less_gexp_aux x y = (\<not>(less_gexp_aux y x) \<and> (x \<noteq> y))"
proof (induct x y rule: less_gexp_aux.induct)
  case (1 b1 b2)
  then show ?case by auto
next
  case ("2_1" b1 v va)
  then show ?case by auto
next
  case ("2_2" b1 v va)
  then show ?case by auto
next
  case ("2_3" b1 v va)
  then show ?case by auto
next
  case ("2_4" b1 v va)
  then show ?case by auto
next
  case (3 e1 e2 b2)
  then show ?case by auto
next
  case (4 e1 e2 e1' e2')
  then show ?case
    by (metis less_gexp_aux.simps(7) less_imp_not_less less_linear)
next
  case ("5_1" e1 e2 v va)
  then show ?case by auto
next
  case ("5_2" e1 e2 v va)
  then show ?case by auto
next
  case ("5_3" e1 e2 v va)
  then show ?case by auto
next
  case (6 e1 e2 b2)
  then show ?case by auto
next
  case (7 e1 e2 e1' e2')
  then show ?case by auto
next
  case (8 e1 e2 e1' e2')
  then show ?case
    by (metis less_gexp_aux.simps(13) less_imp_not_less less_linear)
next
  case ("9_1" e1 e2 v va)
  then show ?case by auto
next
  case ("9_2" e1 e2 v va)
  then show ?case by auto
next
  case (10 vb vc v va)
  then show ?case by auto
next
  case (11 vb vc v va)
  then show ?case by auto
next
  case ("12_1" vb vc v)
  then show ?case by auto
next
  case ("12_2" vb vc v va)
  then show ?case by auto
next
  case ("12_3" vb vc v va)
  then show ?case by auto
next
  case (13 g1 g2 g1' g2')
  then show ?case by auto
next
  case ("14_1" g1 g2 v)
  then show ?case by auto
next
  case ("14_2" g1 g2 v va)
  then show ?case by auto
next
  case ("14_3" g1 g2 v va)
  then show ?case by auto
next
  case ("14_4" g1 g2 v va)
  then show ?case by auto
qed

lemma less_gexp_antisym: "(x::'a gexp) < y = (\<not>(y < x) \<and> (x \<noteq> y))"
  apply (simp add: Let_def)
  apply standard
  using less_gexp_aux_antisym apply blast
  apply clarsimp
  by (induct x, auto)

lemma less_gexp_aux_trans: "less_gexp_aux x y \<Longrightarrow> less_gexp_aux y z \<Longrightarrow> less_gexp_aux x z"
proof(induct x y arbitrary: z rule: less_gexp_aux.induct)
case (1 b1 b2)
  then show ?case by (cases z, auto)
next
  case ("2_1" b1 v va)
  then show ?case by (cases z, auto)
next
  case ("2_2" b1 v va)
  then show ?case by (cases z, auto)
next
  case ("2_3" b1 v va)
  then show ?case by (cases z, auto)
next
  case ("2_4" b1 v va)
  then show ?case by (cases z, auto)
next
  case (3 e1 e2 b2)
  then show ?case by (cases z, auto)
next
  case (4 e1 e2 e1' e2')
  then show ?case
    apply (cases z)
        apply simp
       apply (metis dual_order.strict_trans less_gexp_aux.simps(7))
    by auto
next
  case ("5_1" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case ("5_2" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case ("5_3" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case (6 e1 e2 b2)
  then show ?case by (cases z, auto)
next
  case (7 e1 e2 e1' e2')
  then show ?case by (cases z, auto)
next
  case (8 e1 e2 e1' e2')
  then show ?case
    apply (cases z)
        apply simp
       apply simp
      apply (metis dual_order.strict_trans less_gexp_aux.simps(13))
    by auto
next
  case ("9_1" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case ("9_2" e1 e2 v va)
  then show ?case by (cases z, auto)
next
  case (10 vb vc v va)
  then show ?case by (cases z, auto)
next
  case (11 vb vc v va)
  then show ?case by (cases z, auto)
next
  case ("12_1" vb vc v)
  then show ?case by (cases z, auto)
next
  case ("12_2" vb vc v va)
  then show ?case by (cases z, auto)
next
  case ("12_3" vb vc v va)
  then show ?case by (cases z, auto)
next
  case (13 g1 g2 g1' g2')
  then show ?case by (cases z, auto)
next
  case ("14_1" g1 g2 v)
  then show ?case by (cases z, auto)
next
  case ("14_2" g1 g2 v va)
  then show ?case by (cases z, auto)
next
  case ("14_3" g1 g2 v va)
  then show ?case by (cases z, auto)
next
  case ("14_4" g1 g2 v va)
  then show ?case by (cases z, auto)
qed

lemma less_gexp_trans: "(x::'a gexp) < y \<Longrightarrow> y < z \<Longrightarrow> x < z"
  apply (simp add: Let_def)
  by (metis (no_types, lifting) dual_order.strict_trans less_gexp_aux_trans less_imp_not_less)

instance proof
  fix x y z :: "'a gexp"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (metis less_gexp_antisym less_eq_gexp_def)
  show "(x \<le> x)"
    by (simp add: less_eq_gexp_def)
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (metis less_eq_gexp_def less_gexp_trans)
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    unfolding less_eq_gexp_def using less_gexp_antisym by blast
  show "x \<le> y \<or> y \<le> x"
    unfolding less_eq_gexp_def using less_gexp_antisym by blast
qed
end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Author: Rafal Kolanski, 2008
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter \<open>More properties of maps plus map disjuction.\<close>

theory Map_Extra
imports Main
begin

text \<open>
  A note on naming:
  Anything not involving heap disjuction can potentially be incorporated
  directly into Map.thy, thus uses @{text "m"} for map variable names.
  Anything involving heap disjunction is not really mergeable with Map, is
  destined for use in separation logic, and hence uses @{text "h"}
\<close>

section \<open>Things that could go into Option Type\<close>

text \<open>Misc option lemmas\<close>

lemma None_not_eq: "(None \<noteq> x) = (\<exists>y. x = Some y)" by (cases x) auto

lemma None_com: "(None = x) = (x = None)" by fast

lemma Some_com: "(Some y = x) = (x = Some y)" by fast

section \<open>Things that go into Map.thy\<close>

text \<open>Map intersection: set of all keys for which the maps agree.\<close>

definition
  map_inter :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" (infixl "\<inter>\<^sub>m" 70) where
  "m\<^sub>1 \<inter>\<^sub>m m\<^sub>2 \<equiv> {x \<in> dom m\<^sub>1. m\<^sub>1 x = m\<^sub>2 x}"

text \<open>Map restriction via domain subtraction\<close>

definition
  sub_restrict_map :: "('a \<rightharpoonup> 'b) => 'a set => ('a \<rightharpoonup> 'b)" (infixl "`-"  110)
  where
  "m `- S \<equiv> (\<lambda>x. if x \<in> S then None else m x)"

subsection \<open>Properties of maps not related to restriction\<close>

lemma empty_forall_equiv: "(m = Map.empty) = (\<forall>x. m x = None)"
  by (rule fun_eq_iff)

lemma map_le_empty2 [simp]:
  "(m \<subseteq>\<^sub>m Map.empty) = (m = Map.empty)"
  by (auto simp: map_le_def)

lemma dom_iff:
  "(\<exists>y. m x = Some y) = (x \<in> dom m)"
  by auto

lemma non_dom_eval:
  "x \<notin> dom m \<Longrightarrow> m x = None"
  by auto

lemma non_dom_eval_eq:
  "x \<notin> dom m = (m x = None)"
  by auto

lemma map_add_same_left_eq:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> (m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1')"
  by simp

lemma map_add_left_cancelI [intro!]:
  "m\<^sub>1 = m\<^sub>1' \<Longrightarrow> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0 ++ m\<^sub>1'"
  by simp

lemma dom_empty_is_empty:
  "(dom m = {}) = (m = Map.empty)"
proof (rule iffI)
  assume a: "dom m = {}"
  { assume "m \<noteq> Map.empty"
    hence "dom m \<noteq> {}"
      by - (subst (asm) empty_forall_equiv, simp add: dom_def)
    hence False using a by blast
  }
  thus "m = Map.empty" by blast
next
  assume a: "m = Map.empty"
  thus "dom m = {}" by simp
qed

lemma map_add_dom_eq:
  "dom m = dom m' \<Longrightarrow> m ++ m' = m'"
  by (rule ext) (auto simp: map_add_def split: option.splits)

lemma map_add_right_dom_eq:
  "\<lbrakk> m\<^sub>0 ++ m\<^sub>1 = m\<^sub>0' ++ m\<^sub>1'; dom m\<^sub>1 = dom m\<^sub>1' \<rbrakk> \<Longrightarrow> m\<^sub>1 = m\<^sub>1'"
  unfolding map_add_def
  by (rule ext, rule ccontr,
      drule_tac x=x in fun_cong, clarsimp split: option.splits,
      drule sym, drule sym, force+)

lemma map_le_same_dom_eq:
  "\<lbrakk> m\<^sub>0 \<subseteq>\<^sub>m m\<^sub>1 ; dom m\<^sub>0 = dom m\<^sub>1 \<rbrakk> \<Longrightarrow> m\<^sub>0 = m\<^sub>1"
  by (simp add: map_le_antisym map_le_def)

subsection \<open>Properties of map restriction\<close>

lemma restrict_map_cancel:
  "(m |` S = m |` T) = (dom m \<inter> S = dom m \<inter> T)"
  by (fastforce dest: fun_cong simp: restrict_map_def None_not_eq split: if_split_asm)

lemma map_add_restricted_self [simp]:
  "m ++ m |` S = m"
  by (auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_dom_right [simp]:
  "(m ++ m') |` dom m' = m'"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_UNIV [simp]:
  "m |` UNIV = m"
  by (simp add: restrict_map_def)

lemma restrict_map_dom:
  "S = dom m \<Longrightarrow> m |` S = m"
  by (rule ext, auto simp: restrict_map_def None_not_eq)

lemma restrict_map_subdom:
  "dom m \<subseteq> S \<Longrightarrow> m |` S = m"
  by (fastforce simp: restrict_map_def None_com)

lemma map_add_restrict:
  "(m\<^sub>0 ++ m\<^sub>1) |` S = ((m\<^sub>0 |` S) ++ (m\<^sub>1 |` S))"
  by (force simp: map_add_def restrict_map_def)

lemma map_le_restrict:
  "m \<subseteq>\<^sub>m m' \<Longrightarrow> m = m' |` dom m"
  by (force simp: map_le_def restrict_map_def None_com)

lemma restrict_map_le:
  "m |` S \<subseteq>\<^sub>m m"
  by (auto simp: map_le_def)

lemma restrict_map_remerge:
  "\<lbrakk> S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m |` (S \<union> T)"
  by (rule ext, clarsimp simp: restrict_map_def map_add_def
                         split: option.splits)

lemma restrict_map_empty:
  "dom m \<inter> S = {} \<Longrightarrow> m |` S = Map.empty"
  by (fastforce simp: restrict_map_def)

lemma map_add_restrict_comp_right [simp]:
  "(m |` S ++ m |` (UNIV - S)) = m"
  by (force simp: map_add_def restrict_map_def split: option.splits)

lemma map_add_restrict_comp_right_dom [simp]:
  "(m |` S ++ m |` (dom m - S)) = m"
  by (rule ext, auto simp: map_add_def restrict_map_def split: option.splits)

lemma map_add_restrict_comp_left [simp]:
  "(m |` (UNIV - S) ++ m |` S) = m"
  by (subst map_add_comm, auto)

lemma restrict_self_UNIV:
  "m |` (dom m - S) = m |` (UNIV - S)"
  by (rule ext, auto simp: restrict_map_def)

lemma map_add_restrict_nonmember_right:
  "x \<notin> dom m' \<Longrightarrow> (m ++ m') |` {x} = m |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_nonmember_left:
  "x \<notin> dom m \<Longrightarrow> (m ++ m') |` {x} = m' |` {x}"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma map_add_restrict_right:
  "x \<subseteq> dom m' \<Longrightarrow> (m ++ m') |` x = m' |` x"
  by (rule ext, auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_compose:
  "\<lbrakk> S \<union> T = dom m ; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` S ++ m |` T = m"
  by (fastforce simp: map_add_def restrict_map_def)

lemma map_le_dom_subset_restrict:
  "\<lbrakk> m' \<subseteq>\<^sub>m m; dom m' \<subseteq> S \<rbrakk> \<Longrightarrow> m' \<subseteq>\<^sub>m (m |` S)"
  by (force simp: restrict_map_def map_le_def)

lemma map_le_dom_restrict_sub_add:
  "m' \<subseteq>\<^sub>m m \<Longrightarrow> m |` (dom m - dom m') ++ m' = m"
  by (rule ext, auto simp: None_com map_add_def restrict_map_def map_le_def
                     split: option.splits; force simp: Some_com)

lemma subset_map_restrict_sub_add:
  "T \<subseteq> S \<Longrightarrow> m |` (S - T) ++ m |` T = m |` S"
  by (rule ext) (auto simp: restrict_map_def map_add_def split: option.splits)

lemma restrict_map_sub_union:
  "m |` (dom m - (S \<union> T)) = (m |` (dom m - T)) |` (dom m - S)"
  by (auto simp: restrict_map_def)

lemma prod_restrict_map_add:
  "\<lbrakk> S \<union> T = U; S \<inter> T = {} \<rbrakk> \<Longrightarrow> m |` (X \<times> S) ++ m |` (X \<times> T) = m |` (X \<times> U)"
  by (auto simp: map_add_def restrict_map_def split: option.splits)

section \<open>Things that should not go into Map.thy (separation logic)\<close>

subsection \<open>Definitions\<close>

text \<open>Map disjuction\<close>

definition
  map_disj :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool" (infix "\<bottom>" 51) where
  "h\<^sub>0 \<bottom> h\<^sub>1 \<equiv> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"

declare None_not_eq [simp]

subsection \<open>Properties of @{term "sub_restrict_map"}\<close>

lemma restrict_map_sub_add: "h |` S ++ h `- S = h"
  by (fastforce simp: sub_restrict_map_def restrict_map_def map_add_def
               split: option.splits if_split)

subsection \<open>Properties of map disjunction\<close>

lemma map_disj_empty_right [simp]:
  "h \<bottom> Map.empty"
  by (simp add: map_disj_def)

lemma map_disj_empty_left [simp]:
  "Map.empty \<bottom> h"
  by (simp add: map_disj_def)

lemma map_disj_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_def, fast)

lemma map_disjD:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> dom h\<^sub>0 \<inter> dom h\<^sub>1 = {}"
  by (simp add: map_disj_def)

lemma map_disjI:
  "dom h\<^sub>0 \<inter> dom h\<^sub>1 = {} \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1"
  by (simp add: map_disj_def)

subsection \<open>Map associativity-commutativity based on map disjuction\<close>

lemma map_add_com:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>1 ++ h\<^sub>0"
  by (drule map_disjD, rule map_add_comm, force)

lemma map_add_left_commute:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 ++ (h\<^sub>1 ++ h\<^sub>2) = h\<^sub>1 ++ (h\<^sub>0 ++ h\<^sub>2)"
  by (simp add: map_add_com map_disj_com)

lemma map_add_disj:
  "h\<^sub>0 \<bottom> (h\<^sub>1 ++ h\<^sub>2) = (h\<^sub>0 \<bottom> h\<^sub>1 \<and> h\<^sub>0 \<bottom> h\<^sub>2)"
  by (simp add: map_disj_def, fast)

lemma map_add_disj':
  "(h\<^sub>1 ++ h\<^sub>2) \<bottom> h\<^sub>0 = (h\<^sub>1 \<bottom> h\<^sub>0 \<and> h\<^sub>2 \<bottom> h\<^sub>0)"
  by (simp add: map_disj_def, fast)

text \<open>
  We redefine @{term "map_add"} associativity to bind to the right, which
  seems to be the more common case.
  Note that when a theory includes Map again, @{text "map_add_assoc"} will
  return to the simpset and will cause infinite loops if its symmetric
  counterpart is added (e.g. via @{text "map_add_ac"})
\<close>

declare map_add_assoc [simp del]

text \<open>
  Since the associativity-commutativity of @{term "map_add"} relies on
  map disjunction, we include some basic rules into the ac set.
\<close>

lemmas map_add_ac =
  map_add_assoc[symmetric] map_add_com map_disj_com
  map_add_left_commute map_add_disj map_add_disj'

subsection \<open>Basic properties\<close>

lemma map_disj_None_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; x \<in> dom h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None"
  by (auto simp: map_disj_def dom_def)

lemma map_disj_None_left':
  "\<lbrakk> h\<^sub>0 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>1 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_None_right':
  "\<lbrakk> h\<^sub>1 x = Some y ; h\<^sub>1 \<bottom> h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 x = None "
  by (auto simp: map_disj_def)

lemma map_disj_common:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0 p = Some v ; h\<^sub>1 p = Some v' \<rbrakk> \<Longrightarrow> False"
  by (frule (1) map_disj_None_left', simp)

lemma map_disj_eq_dom_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; dom h\<^sub>0' = dom h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (auto simp: map_disj_def)

subsection \<open>Map disjunction and addition\<close>

lemma map_add_eval_left:
  "\<lbrakk> x \<in> dom h ; h \<bottom> h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h x"
  by (auto dest!: map_disj_None_right simp: map_add_def cong: option.case_cong)

lemma map_add_eval_right:
  "\<lbrakk> x \<in> dom h' \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (rule map_add_dom_app_simps)

lemma map_add_eval_right':
  "\<lbrakk> x \<notin> dom h \<rbrakk> \<Longrightarrow> (h ++ h') x = h' x"
  by (rule map_add_dom_app_simps)

lemma map_add_left_dom_eq:
  assumes eq: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'"
  assumes etc: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'" "dom h\<^sub>0 = dom h\<^sub>0'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  from eq have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using etc by (simp add: map_add_ac)
  thus ?thesis using etc
    by (fastforce elim!: map_add_right_dom_eq simp: map_add_ac)
qed

lemma map_add_left_eq:
  assumes eq: "h\<^sub>0 ++ h = h\<^sub>1 ++ h"
  assumes disj: "h\<^sub>0 \<bottom> h" "h\<^sub>1 \<bottom> h"
  shows "h\<^sub>0 = h\<^sub>1"
proof (rule ext)
  fix x
  from eq have eq': "(h\<^sub>0 ++ h) x = (h\<^sub>1 ++ h) x" by auto
  { assume "x \<in> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj by (simp add: map_disj_None_left)
  } moreover {
    assume "x \<notin> dom h"
    hence "h\<^sub>0 x = h\<^sub>1 x" using disj eq' by (simp add: map_add_eval_left')
  }
  ultimately show "h\<^sub>0 x = h\<^sub>1 x" by cases
qed

lemma map_add_right_eq:
  "\<lbrakk>h ++ h\<^sub>0 = h ++ h\<^sub>1; h\<^sub>0 \<bottom> h; h\<^sub>1 \<bottom> h\<rbrakk> \<Longrightarrow> h\<^sub>0 = h\<^sub>1"
  by (rule_tac h=h in map_add_left_eq, auto simp: map_add_ac)

lemma map_disj_add_eq_dom_right_eq:
  assumes merge: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and d: "dom h\<^sub>0 = dom h\<^sub>0'" and
      ab_disj: "h\<^sub>0 \<bottom> h\<^sub>1" and cd_disj: "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>1 = h\<^sub>1'"
proof (rule ext)
  fix x
  from merge have merge_x: "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0' ++ h\<^sub>1') x" by simp
  with d ab_disj cd_disj show  "h\<^sub>1 x = h\<^sub>1' x"
    by - (case_tac "h\<^sub>1 x", case_tac "h\<^sub>1' x", simp, fastforce simp: map_disj_def,
          case_tac "h\<^sub>1' x", clarsimp, simp add: Some_com,
          force simp: map_disj_def, simp)
qed

lemma map_disj_add_eq_dom_left_eq:
  assumes add: "h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'" and
          dom: "dom h\<^sub>1 = dom h\<^sub>1'" and
          disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0' \<bottom> h\<^sub>1'"
  shows "h\<^sub>0 = h\<^sub>0'"
proof -
  have "h\<^sub>1 ++ h\<^sub>0 = h\<^sub>1' ++ h\<^sub>0'" using add disj by (simp add: map_add_ac)
  thus ?thesis using dom disj
    by - (rule map_disj_add_eq_dom_right_eq, auto simp: map_disj_com)
qed

lemma map_add_left_cancel:
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1" "h\<^sub>0 \<bottom> h\<^sub>1'"
  shows "(h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0 ++ h\<^sub>1') = (h\<^sub>1 = h\<^sub>1')"
proof (rule iffI, rule ext)
  fix x
  assume "(h\<^sub>0 ++ h\<^sub>1) = (h\<^sub>0 ++ h\<^sub>1')"
  hence "(h\<^sub>0 ++ h\<^sub>1) x = (h\<^sub>0 ++ h\<^sub>1') x" by auto
  hence "h\<^sub>1 x = h\<^sub>1' x" using disj
    by (cases "x \<in> dom h\<^sub>0"; simp add: map_disj_None_right map_add_eval_right')
  thus "h\<^sub>1 x = h\<^sub>1' x" by auto
qed auto

lemma map_add_lr_disj:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 = h\<^sub>0' ++ h\<^sub>1'; h\<^sub>1 \<bottom> h\<^sub>1'  \<rbrakk> \<Longrightarrow> dom h\<^sub>1 \<subseteq> dom h\<^sub>0'"
  by (clarsimp simp: map_disj_def map_add_def, drule_tac x=x in fun_cong)
     (auto split: option.splits)

subsection \<open>Map disjunction and map updates\<close>

lemma map_disj_update_left [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1(p \<mapsto> v) = h\<^sub>0 \<bottom> h\<^sub>1"
  by (clarsimp simp: map_disj_def, blast)

lemma map_disj_update_right [simp]:
  "p \<in> dom h\<^sub>1 \<Longrightarrow> h\<^sub>1(p \<mapsto> v) \<bottom> h\<^sub>0 = h\<^sub>1 \<bottom> h\<^sub>0"
  by (simp add: map_disj_com)

lemma map_add_update_left:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>0 \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0(p \<mapsto> v) ++ h\<^sub>1)"
  by (drule (1) map_disj_None_right)
     (auto simp: map_add_def cong: option.case_cong)

lemma map_add_update_right:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; p \<in> dom h\<^sub>1  \<rbrakk> \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>1)(p \<mapsto> v) = (h\<^sub>0 ++ h\<^sub>1 (p \<mapsto> v))"
  by (drule (1) map_disj_None_left)
     (auto simp: map_add_def cong: option.case_cong)

subsection \<open>Map disjunction and @{term "map_le"}\<close>

lemma map_le_override [simp]:
  "\<lbrakk> h \<bottom> h' \<rbrakk> \<Longrightarrow> h \<subseteq>\<^sub>m h ++ h'"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_leI_left:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h" by auto

lemma map_leI_right:
  "\<lbrakk> h = h\<^sub>0 ++ h\<^sub>1 ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>1 \<subseteq>\<^sub>m h" by auto

lemma map_disj_map_le:
  "\<lbrakk> h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0' \<bottom> h\<^sub>1"
  by (force simp: map_disj_def map_le_def)

lemma map_le_on_disj_left:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>0 ++ h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  unfolding map_le_def
  by (rule ballI, erule_tac x=a in ballE, auto simp: map_add_eval_left)+

lemma map_le_on_disj_right:
  "\<lbrakk> h' \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 ; h' = h\<^sub>1 ++ h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h"
  by (auto simp: map_le_on_disj_left map_add_ac)

lemma map_le_add_cancel:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1 ; h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<rbrakk> \<Longrightarrow> h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  by (auto simp: map_le_def map_add_def map_disj_def split: option.splits)

lemma map_le_override_bothD:
  assumes subm: "h\<^sub>0' ++ h\<^sub>1 \<subseteq>\<^sub>m h\<^sub>0 ++ h\<^sub>1"
  assumes disj': "h\<^sub>0' \<bottom> h\<^sub>1"
  assumes disj: "h\<^sub>0 \<bottom> h\<^sub>1"
  shows "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0"
unfolding map_le_def
proof (rule ballI)
  fix a
  assume a: "a \<in> dom h\<^sub>0'"
  hence sumeq: "(h\<^sub>0' ++ h\<^sub>1) a = (h\<^sub>0 ++ h\<^sub>1) a"
    using subm unfolding map_le_def by auto
  from a have "a \<notin> dom h\<^sub>1" using disj' by (auto dest!: map_disj_None_right)
  thus "h\<^sub>0' a = h\<^sub>0 a" using a sumeq disj disj'
    by (simp add: map_add_eval_left map_add_eval_left')
qed

lemma map_le_conv:
  "(h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 \<and> h\<^sub>0' \<noteq> h\<^sub>0) = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1 \<and> h\<^sub>0' \<noteq> h\<^sub>0)"
  unfolding map_le_def map_disj_def map_add_def
  by (rule iffI,
      clarsimp intro!: exI[where x="\<lambda>x. if x \<notin> dom h\<^sub>0' then h\<^sub>0 x else None"])
     (fastforce intro: split: option.splits if_split_asm)+

lemma map_le_conv2:
  "h\<^sub>0' \<subseteq>\<^sub>m h\<^sub>0 = (\<exists>h\<^sub>1. h\<^sub>0 = h\<^sub>0' ++ h\<^sub>1 \<and> h\<^sub>0' \<bottom> h\<^sub>1)"
  by (case_tac "h\<^sub>0'=h\<^sub>0", insert map_le_conv, auto intro: exI[where x=Map.empty])

subsection \<open>Map disjunction and restriction\<close>

lemma map_disj_comp [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (UNIV - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj:
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_disj_restrict_dom [simp]:
  "h\<^sub>0 \<bottom> h\<^sub>1 |` (dom h\<^sub>1 - dom h\<^sub>0)"
  by (force simp: map_disj_def)

lemma restrict_map_disj_dom_empty:
  "h \<bottom> h' \<Longrightarrow> h |` dom h' = Map.empty"
  by (fastforce simp: map_disj_def restrict_map_def)

lemma restrict_map_univ_disj_eq:
  "h \<bottom> h' \<Longrightarrow> h |` (UNIV - dom h') = h"
  by (rule ext, auto simp: map_disj_def restrict_map_def)

lemma restrict_map_disj_dom:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h |` dom h\<^sub>0 \<bottom> h |` dom h\<^sub>1"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_dom_left:
  "h \<bottom> h' \<Longrightarrow> (h ++ h') |` dom h = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma map_add_restrict_dom_left':
  "h \<bottom> h' \<Longrightarrow> S = dom h \<Longrightarrow> (h ++ h') |` S = h"
  by (rule ext, auto simp: restrict_map_def map_add_def dom_def map_disj_def
                     split: option.splits)

lemma restrict_map_disj_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (auto simp: map_disj_def)

lemmas restrict_map_disj_both = restrict_map_disj_right restrict_map_disj_left

lemma map_dom_disj_restrict_right:
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> (h\<^sub>0 ++ h\<^sub>0') |` dom h\<^sub>1 = h\<^sub>0' |` dom h\<^sub>1"
  by (simp add: map_add_restrict restrict_map_empty map_disj_def)

lemma restrict_map_on_disj:
  "h\<^sub>0' \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 |` dom h\<^sub>0' \<bottom> h\<^sub>1"
  unfolding map_disj_def by auto

lemma restrict_map_on_disj':
  "h\<^sub>0 \<bottom> h\<^sub>1 \<Longrightarrow> h\<^sub>0 \<bottom> h\<^sub>1 |` S"
  by (rule restrict_map_disj_right)

lemma map_le_sub_dom:
  "\<lbrakk> h\<^sub>0 ++ h\<^sub>1 \<subseteq>\<^sub>m h ; h\<^sub>0 \<bottom> h\<^sub>1 \<rbrakk> \<Longrightarrow> h\<^sub>0 \<subseteq>\<^sub>m h |` (dom h - dom h\<^sub>1)"
  by (rule map_le_override_bothD, subst map_le_dom_restrict_sub_add)
     (auto elim: map_add_le_mapE simp: map_add_ac)

lemma map_submap_break:
  "\<lbrakk> h \<subseteq>\<^sub>m h' \<rbrakk> \<Longrightarrow> h' = (h' |` (UNIV - dom h)) ++ h"
  by (fastforce split: option.splits
                simp: map_le_restrict restrict_map_def map_le_def map_add_def
                      dom_def)

lemma map_add_disj_restrict_both:
  "\<lbrakk> h\<^sub>0 \<bottom> h\<^sub>1; S \<inter> S' = {}; T \<inter> T' = {} \<rbrakk>
   \<Longrightarrow> (h\<^sub>0 |` S) ++ (h\<^sub>1 |` T) \<bottom> (h\<^sub>0 |` S') ++ (h\<^sub>1 |` T')"
  by (auto simp: map_add_ac intro!: restrict_map_disj_both restrict_map_disj)

end


theory sort_TSortIsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype 'a Tree = TNode "'a Tree" "'a" "'a Tree" | TNil

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun flatten :: "'a Tree => 'a list => 'a list" where
"flatten (TNode p z q) y = flatten p (Cons2 z (flatten q y))"
| "flatten (TNil) y = y"

fun dot :: "('b => 'c) => ('a => 'b) => 'a => 'c" where
"dot x y z = x (y z)"

fun add :: "int => int Tree => int Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode (TNil) x (TNil)"

fun toTree :: "int list => int Tree" where
"toTree (Nil2) = TNil"
| "toTree (Cons2 y xs) = add y (toTree xs)"

fun tsort :: "int list => int list" where
"tsort x =
   dot
     (% (y :: (int list => int list)) => y (Nil2))
     (% (z :: int list) =>
        dot
          (% (x2 :: int Tree) => % (x3 :: int list) => flatten x2 x3)
          (% (x4 :: int list) => toTree x4) z)
     x"

(*hipster insert2 isort flatten dot add toTree tsort *)

theorem x0 :
  "!! (x :: int list) . (tsort x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:      ZF/Induct/Acc.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section {* The accessible part of a relation *}

theory Acc imports Main begin

text {*
  Inductive definition of @{text "acc(r)"}; see @{cite "paulin-tlca"}.
*}

consts
  acc :: "i => i"

inductive
  domains "acc(r)" \<subseteq> "field(r)"
  intros
    vimage:  "[| r-``{a}: Pow(acc(r)); a \<in> field(r) |] ==> a \<in> acc(r)"
  monos      Pow_mono

text {*
  The introduction rule must require @{prop "a \<in> field(r)"},
  otherwise @{text "acc(r)"} would be a proper class!

  \medskip
  The intended introduction rule:
*}

lemma accI: "[| !!b. <b,a>:r ==> b \<in> acc(r);  a \<in> field(r) |] ==> a \<in> acc(r)"
  by (blast intro: acc.intros)

lemma acc_downward: "[| b \<in> acc(r);  <a,b>: r |] ==> a \<in> acc(r)"
  by (erule acc.cases) blast

lemma acc_induct [consumes 1, case_names vimage, induct set: acc]:
    "[| a \<in> acc(r);
        !!x. [| x \<in> acc(r);  \<forall>y. <y,x>:r \<longrightarrow> P(y) |] ==> P(x)
     |] ==> P(a)"
  by (erule acc.induct) (blast intro: acc.intros)

lemma wf_on_acc: "wf[acc(r)](r)"
  apply (rule wf_onI2)
  apply (erule acc_induct)
  apply fast
  done

lemma acc_wfI: "field(r) \<subseteq> acc(r) \<Longrightarrow> wf(r)"
  by (erule wf_on_acc [THEN wf_on_subset_A, THEN wf_on_field_imp_wf])

lemma acc_wfD: "wf(r) ==> field(r) \<subseteq> acc(r)"
  apply (rule subsetI)
  apply (erule wf_induct2, assumption)
   apply (blast intro: accI)+
  done

lemma wf_acc_iff: "wf(r) \<longleftrightarrow> field(r) \<subseteq> acc(r)"
  by (rule iffI, erule acc_wfD, erule acc_wfI)

end