unicode-logic-kit 0.31.0__py3-none-any.whl

unicode_logic_kit/hol/deepshallow/__init__.py

@@ -0,0 +1,45 @@
+r"""Deep + maximal-shallow + minimal-shallow HOL embeddings with faithfulness proofs.
+
+Reproduces, per non-classical object logic, the three faithful HOL embeddings of
+Benzmüller, *Faithful Logic Embeddings in HOL — Deep and Shallow*
+(arXiv:2502.19311v3), together with the **machine-checked faithfulness proofs**
+relating them. See :mod:`unicode_logic_kit.hol.deepshallow._common` for the shared
+construction and honesty notes.
+
+Currently provided (Tier 1 — worlds-based logics that carry the deep/maximal/minimal
++ faithfulness scheme cleanly):
+
+- :mod:`~unicode_logic_kit.hol.deepshallow.modal` — propositional modal logic K.
+- :mod:`~unicode_logic_kit.hol.deepshallow.intuitionistic` — intuitionistic
+  propositional logic (Kripke semantics).
+- :mod:`~unicode_logic_kit.hol.deepshallow.conditional` — Lewis counterfactual
+  (sphere) logic.
+- :mod:`~unicode_logic_kit.hol.deepshallow.relevant` — relevant logic B
+  (simplified Routley–Meyer semantics).
+
+Tier 2 (K, constant domain only) — the first *quantified* member of the family,
+with a genuinely binder-carrying deep embedding (de Bruijn-indexed object
+variables) rather than a propositional/schematic syntax tree:
+
+- :mod:`~unicode_logic_kit.hol.deepshallow.qml` — quantified modal logic, scoped to
+  the base frame K, the CONSTANT domain regime, and the alethic ``□``/``◇``
+  modalities only. Every other frame, domain regime, agent-indexed/temporal/
+  deontic operator, equality and function term is refused by name — see the
+  module docstring and :mod:`unicode_logic_kit.hol.isabelle_modal` for those.
+"""
+
+from .modal import modal_faithfulness_theory, modal_to_deep
+from .intuitionistic import intuitionistic_faithfulness_theory, int_to_deep
+from .conditional import conditional_faithfulness_theory, counterfactual_to_deep
+from .relevant import relevant_faithfulness_theory, rel_to_deep
+from .qml import qml_deep_faithfulness_theory, qml_to_deep
+from ._common import AtomConsts, sanitize_atom
+
+__all__ = [
+    "modal_faithfulness_theory", "modal_to_deep",
+    "intuitionistic_faithfulness_theory", "int_to_deep",
+    "conditional_faithfulness_theory", "counterfactual_to_deep",
+    "relevant_faithfulness_theory", "rel_to_deep",
+    "qml_deep_faithfulness_theory", "qml_to_deep",
+    "AtomConsts", "sanitize_atom",
+]

unicode_logic_kit/hol/deepshallow/_common.py

@@ -0,0 +1,177 @@
+r"""Shared scaffolding for the deep / maximal-shallow / minimal-shallow embeddings.
+
+This subpackage reproduces, per non-classical object logic, the three faithful
+HOL embeddings of Benzmüller, *Faithful Logic Embeddings in HOL — Deep and
+Shallow* (arXiv:2502.19311v3) and the **machine-checked faithfulness proofs**
+between them:
+
+- a **deep** embedding (the object syntax as an Isabelle ``datatype`` with a
+  recursive ``primrec`` truth predicate ``truthD``), enabling reasoning *about*
+  the object logic (induction over formula structure, meta-theorems);
+- a **maximal (heavyweight) shallow** embedding (formulas as predicates with
+  *every* semantic parameter explicit, ``... \<Rightarrow> w \<Rightarrow> bool``);
+- a **minimal (lightweight) shallow** embedding (the accessibility structure and
+  valuation fixed as metalogical ``consts``, formulas as ``w \<Rightarrow> bool``) — the
+  variant the paper found automates best, and the style of the toolkit's existing
+  :mod:`unicode_logic_kit.hol.isabelle_modal` decision path;
+- and the ``primrec`` mappings ``dpToMax`` / ``dpToMin`` plus the theorems
+  ``faithful1a/1b`` (deep \<leftrightarrow> maximal), ``faithful2/3`` (deep/maximal
+  \<leftrightarrow> minimal in the fixed model) and ``sound_min``, each closed by a
+  one-line ``induct`` proof.
+
+The toolkit only *emits* these theories. With a local Isabelle/HOL they are
+**machine-verified** end to end via
+:func:`unicode_logic_kit.hol.isabelle_runner.check_theory` (exit 0 \<Longrightarrow>
+Isabelle's kernel discharged every ``induct`` proof); this is what the
+Isabelle-gated tests assert. Without Isabelle, the emitted text still has a fixed,
+tested structure. The stack targets the **propositional / schematic** fragment,
+where induction over the syntax datatype applies; the *quantified* decision path
+stays in :mod:`unicode_logic_kit.hol.isabelle_modal`.
+"""
+
+from dataclasses import dataclass, field
+from typing import Dict, List, Optional, Tuple, Type
+
+from unicode_logic_kit.fol.nodes import Node, Atom, Iff, Xor, Variable, Quantifier
+from unicode_logic_kit.fol._msfl_nodes import key_text
+from unicode_logic_kit.fol._truth_constants import refuse_truth_constants
+
+#: Why a deep embedding refuses the TPTP constants ``$true`` / ``$false``: its
+#: formula datatype has a constructor for an atom and one per connective, and none
+#: for a truth constant, so the only reading it could give one is an unrelated letter.
+NO_CONSTANT_WHY = (
+    "the deep embedding's formula datatype has constructors for atoms and "
+    "connectives only, none for a truth constant, and an atom named $true would "
+    "be a letter that is neither true nor false")
+
+
+def sanitize_atom(name: str) -> str:
+    """Turn a propositional-atom label into a legal lowercase Isabelle constant id.
+
+    Distinct atoms get distinct ``consts`` of the shared signature type ``s``; the
+    resolver (:class:`AtomConsts`) keeps the mapping injective so two source atoms
+    that sanitise alike do not collapse.
+    """
+    out = "".join(c if (c.isalnum() or c == "_") else "_" for c in str(name))
+    if not out:
+        out = "p"
+    if not (out[0].isalpha() or out[0] == "_"):
+        out = "p_" + out
+    return "p_" + out if not out.startswith("p_") else out
+
+
+@dataclass
+class AtomConsts:
+    """Injective map from propositional-atom label to an Isabelle ``s`` constant.
+
+    Encoders call :meth:`name` while walking a formula; :meth:`decls` then yields the
+    ``consts NAME :: "s"`` declarations for exactly the atoms that occurred.
+    """
+
+    _by_label: Dict[str, str] = field(default_factory=dict)
+    _used: set = field(default_factory=set)
+
+    def name(self, label: str) -> str:
+        """The constant naming propositional atom ``label`` (stable, de-collided)."""
+        if label in self._by_label:
+            return self._by_label[label]
+        base = sanitize_atom(label)
+        cand, k = base, 1
+        while cand in self._used:
+            k += 1
+            cand = f"{base}_{k}"
+        self._by_label[label] = cand
+        self._used.add(cand)
+        return cand
+
+    def decls(self, typ: str = "s") -> List[str]:
+        """``consts`` lines for every atom constant handed out (sorted, stable).
+
+        ``typ`` is the Isabelle type ascribed to each constant. It defaults to the
+        signature type ``s`` the deep embeddings index their valuation by; a shallow
+        decision theory that has no separate valuation passes the world-predicate
+        type instead.
+        """
+        return [f'consts {c} :: "{typ}"' for c in sorted(self._by_label.values())]
+
+
+def theory_name_ok(name: str) -> bool:
+    """True if ``name`` is a legal Isabelle theory identifier (letters/digits/_)."""
+    return bool(name) and name[0].isalpha() and all(
+        c.isalnum() or c == "_" for c in name)
+
+
+def _atom_is_propositional(node: Atom) -> bool:
+    """True unless an argument carries a :class:`Variable` (⇒ genuinely first-order)."""
+    return not any(isinstance(n, Variable) for a in node.args for n in a.walk())
+
+
+def encode_deep(formula: Node, atoms: AtomConsts,
+                ctors: Dict[Type[Node], Tuple[str, int]], *,
+                logic: str, allow_xor: bool = True) -> str:
+    r"""Encode a **propositional** formula as a deep datatype term.
+
+    Shared by the per-logic encoders. ``ctors`` maps a toolkit node type to its deep
+    constructor name and arity (1 ⇒ ``.formula`` child, 2 ⇒ ``.left`` / ``.right``);
+    each distinct ground atom becomes an ``s`` constant collected into ``atoms``.
+    ``Xor`` desugars to ``NegD (IffD ...)`` when ``allow_xor``. Raises
+    :class:`NotImplementedError` on a quantifier, a free variable, or any node type
+    absent from ``ctors`` — the deep embedding is propositional.
+    """
+    if isinstance(formula, Atom):
+        refuse_truth_constants([formula], logic, NO_CONSTANT_WHY)
+        if not _atom_is_propositional(formula):
+            raise NotImplementedError(
+                f"{logic}: atom with a free variable is first-order; the deep "
+                "embedding is propositional.")
+        return f"(Atm {atoms.name(key_text(formula))})"
+    if isinstance(formula, (Quantifier, Variable)):
+        raise NotImplementedError(
+            f"{logic}: quantifiers/variables are first-order; the deep embedding is "
+            "propositional.")
+    if isinstance(formula, Xor):
+        if not (allow_xor and Iff in ctors):
+            raise NotImplementedError(f"{logic}: Xor is not supported.")
+        left = encode_deep(formula.left, atoms, ctors, logic=logic, allow_xor=allow_xor)
+        right = encode_deep(formula.right, atoms, ctors, logic=logic, allow_xor=allow_xor)
+        return f"(NegD (IffD {left} {right}))"
+    spec = ctors.get(type(formula))
+    if spec is None:
+        if type(formula).__name__ == "Nominal":
+            raise NotImplementedError(
+                f"{logic}: a bare lowercase name parses as a hybrid-logic NOMINAL in "
+                "modal mode, not a propositional atom. Write atoms as 0-ary predicates "
+                "(e.g. P()) or build Atom nodes directly.")
+        raise NotImplementedError(
+            f"{logic}: unsupported node type {type(formula).__name__} "
+            "(the deep embedding covers the propositional fragment only). For "
+            "the full modal family — epistemic/doxastic/assertive/bouletic, "
+            "deontic, temporal incl. Until/Since, hybrid — use "
+            "hol.isabelle_modal.to_isabelle_modal / isabelle_decide_modal or "
+            "hol.thf_modal.to_thf_modal_full instead.")
+    name, arity = spec
+    if arity == 1:
+        inner = encode_deep(formula.formula, atoms, ctors, logic=logic, allow_xor=allow_xor)
+        return f"({name} {inner})"
+    left = encode_deep(formula.left, atoms, ctors, logic=logic, allow_xor=allow_xor)
+    right = encode_deep(formula.right, atoms, ctors, logic=logic, allow_xor=allow_xor)
+    return f"({name} {left} {right})"
+
+
+def wrap_theory(theory_name: str, body: str, extra: str = "") -> str:
+    """Wrap a verified theory ``body`` in ``theory <name> imports Main begin ... end``."""
+    if not theory_name_ok(theory_name):
+        raise ValueError(f"illegal theory name {theory_name!r}.")
+    parts = [f"theory {theory_name}", "  imports Main", "begin", "", body, ""]
+    if extra:
+        parts.append(extra)
+    parts.append("end")
+    return "\n".join(parts) + "\n"
+
+
+def formula_section(term: str, atoms: AtomConsts, datatype: str) -> str:
+    """The ``consts`` + ``definition example`` block grounding a concrete formula."""
+    lines = ["", "section \\<open>A concrete embedded formula\\<close>", ""]
+    lines += atoms.decls()
+    lines.append(f'definition example :: {datatype} where "example = {term}"')
+    return "\n".join(lines)

unicode_logic_kit/hol/deepshallow/conditional.py

@@ -0,0 +1,225 @@
+r"""Deep + maximal-shallow + minimal-shallow embeddings of **Lewis counterfactual
+(sphere) logic**, with machine-checked faithfulness proofs.
+
+The Boolean base is classical (per-world), and the counterfactual ``A \<box>\<rightarrow> B`` is
+read over a system of spheres ``Sph x S`` (``S`` is a sphere of worlds around ``x``,
+innermost = closest) with Lewis's truth condition — vacuously true if no sphere holds
+an ``A``-world, else some sphere holds an ``A``-world and all its ``A``-worlds are
+``B``-worlds — matching :func:`unicode_logic_kit.semantics.conditional.would`. Validity
+ranges over ``nested`` sphere systems (any two spheres of a world are
+\<subseteq>-comparable), the property Lewis's nested spheres have by construction; that
+is the weakest sphere logic **V**. The dual "might" ``A \<diamond>\<rightarrow> B`` is
+``\<not>(A \<box>\<rightarrow> \<not>B)``.
+
+**Which sphere class this is** — and how it differs from the decision routes. ``validD``
+/ ``validS`` here fix ``nested Sp`` and nothing more, so they denote the class
+:data:`~unicode_logic_kit.semantics.conditional.CENTERING_LEVELS`'s ``"none"`` names, i.e.
+Lewis's **V**. :func:`~unicode_logic_kit.semantics.conditional.cf_valid` and
+:func:`~unicode_logic_kit.hol.isabelle_runner.isabelle_decide_counterfactual` default to
+``"weak"`` (**VW**) instead, because modus ponens for ``\<box>\<rightarrow>`` fails in V.
+That difference is deliberate: what is machine-checked in this module is the *faithfulness*
+of the three embeddings to each other, which is a statement about the truth condition and
+holds at every centering level — adding a centering premise here would constrain the
+sphere systems without changing anything the faithfulness theorems say. Do not read a
+``validD`` verdict as a verdict about the logic ``cf_valid`` decides.
+
+The deep term is built from an antecedent/consequent **pair** rather than from a single
+formula node: the encoder predates the ``Would`` / ``Might`` AST nodes and mirrors the
+argument form of ``would`` / ``might``, whose propositional-only contract it shares.
+"""
+
+from typing import Optional
+
+from unicode_logic_kit.fol.nodes import Node, Not, And, Or, Implies, Iff
+from ._common import AtomConsts, encode_deep, wrap_theory, formula_section
+
+# --------------------------------------------------------------------------- #
+# Verified theory body (checked verbatim by the Isabelle-gated tests).
+# --------------------------------------------------------------------------- #
+
+_COND_BODY = r'''typedecl w  \<comment> \<open>worlds\<close>
+typedecl s  \<comment> \<open>signature: propositional symbols (shared by all three embeddings)\<close>
+type_synonym wset = "w \<Rightarrow> bool"
+type_synonym sph  = "w \<Rightarrow> (w \<Rightarrow> bool) \<Rightarrow> bool"   \<comment> \<open>Sph x S: S is a sphere around x\<close>
+type_synonym val  = "s \<Rightarrow> w \<Rightarrow> bool"
+
+definition nested :: "sph \<Rightarrow> bool" where
+  "nested Sp \<equiv> \<forall>x S T. Sp x S \<longrightarrow> Sp x T \<longrightarrow> (\<forall>u. S u \<longrightarrow> T u) \<or> (\<forall>u. T u \<longrightarrow> S u)"
+
+section \<open>Deep embedding: object syntax as a datatype + recursive truth\<close>
+
+datatype cpl =
+    Atm s | TopD | BotD
+  | NegD cpl | AndD cpl cpl | OrD cpl cpl | ImpD cpl cpl | IffD cpl cpl
+  | CondD cpl cpl
+
+primrec truthD :: "wset \<Rightarrow> sph \<Rightarrow> val \<Rightarrow> w \<Rightarrow> cpl \<Rightarrow> bool" where
+  "truthD W Sp V x (Atm p)    = V p x"
+| "truthD W Sp V x TopD       = True"
+| "truthD W Sp V x BotD       = False"
+| "truthD W Sp V x (NegD f)   = (\<not> truthD W Sp V x f)"
+| "truthD W Sp V x (AndD f g) = (truthD W Sp V x f \<and> truthD W Sp V x g)"
+| "truthD W Sp V x (OrD f g)  = (truthD W Sp V x f \<or> truthD W Sp V x g)"
+| "truthD W Sp V x (ImpD f g) = (truthD W Sp V x f \<longrightarrow> truthD W Sp V x g)"
+| "truthD W Sp V x (IffD f g) = (truthD W Sp V x f = truthD W Sp V x g)"
+| "truthD W Sp V x (CondD f g) =
+     ((\<exists>S. Sp x S \<and> (\<exists>u. S u \<and> truthD W Sp V u f)
+                  \<and> (\<forall>u. S u \<longrightarrow> truthD W Sp V u f \<longrightarrow> truthD W Sp V u g))
+      \<or> (\<forall>S. Sp x S \<longrightarrow> (\<forall>u. S u \<longrightarrow> \<not> truthD W Sp V u f)))"
+
+definition validD :: "cpl \<Rightarrow> bool" where
+  "validD f \<equiv> \<forall>W Sp V. nested Sp \<longrightarrow> (\<forall>x. W x \<longrightarrow> truthD W Sp V x f)"
+
+section \<open>Maximal (heavyweight) shallow embedding: every parameter explicit\<close>
+
+type_synonym sigma = "wset \<Rightarrow> sph \<Rightarrow> val \<Rightarrow> w \<Rightarrow> bool"
+definition AtmS :: "s \<Rightarrow> sigma" where "AtmS p \<equiv> \<lambda>W Sp V x. V p x"
+definition TopS :: "sigma" where "TopS \<equiv> \<lambda>W Sp V x. True"
+definition BotS :: "sigma" where "BotS \<equiv> \<lambda>W Sp V x. False"
+definition NegS :: "sigma \<Rightarrow> sigma" where "NegS f \<equiv> \<lambda>W Sp V x. \<not> f W Sp V x"
+definition AndS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "AndS f g \<equiv> \<lambda>W Sp V x. f W Sp V x \<and> g W Sp V x"
+definition OrS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "OrS f g \<equiv> \<lambda>W Sp V x. f W Sp V x \<or> g W Sp V x"
+definition ImpS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "ImpS f g \<equiv> \<lambda>W Sp V x. f W Sp V x \<longrightarrow> g W Sp V x"
+definition IffS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "IffS f g \<equiv> \<lambda>W Sp V x. f W Sp V x = g W Sp V x"
+definition CondS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "CondS f g \<equiv> \<lambda>W Sp V x.
+     (\<exists>S. Sp x S \<and> (\<exists>u. S u \<and> f W Sp V u)
+                 \<and> (\<forall>u. S u \<longrightarrow> f W Sp V u \<longrightarrow> g W Sp V u))
+     \<or> (\<forall>S. Sp x S \<longrightarrow> (\<forall>u. S u \<longrightarrow> \<not> f W Sp V u))"
+definition validS :: "sigma \<Rightarrow> bool" where
+  "validS f \<equiv> \<forall>W Sp V. nested Sp \<longrightarrow> (\<forall>x. W x \<longrightarrow> f W Sp V x)"
+
+section \<open>Minimal (lightweight) shallow embedding: Sph, V fixed as metalogical consts\<close>
+
+consts Sel :: "sph"
+consts Vval :: "val"
+type_synonym tau = "w \<Rightarrow> bool"
+definition AtmM :: "s \<Rightarrow> tau" where "AtmM p \<equiv> \<lambda>x. Vval p x"
+definition TopM :: "tau" where "TopM \<equiv> \<lambda>x. True"
+definition BotM :: "tau" where "BotM \<equiv> \<lambda>x. False"
+definition NegM :: "tau \<Rightarrow> tau" where "NegM f \<equiv> \<lambda>x. \<not> f x"
+definition AndM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where "AndM f g \<equiv> \<lambda>x. f x \<and> g x"
+definition OrM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where "OrM f g \<equiv> \<lambda>x. f x \<or> g x"
+definition ImpM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where "ImpM f g \<equiv> \<lambda>x. f x \<longrightarrow> g x"
+definition IffM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where "IffM f g \<equiv> \<lambda>x. f x = g x"
+definition CondM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where
+  "CondM f g \<equiv> \<lambda>x.
+     (\<exists>S. Sel x S \<and> (\<exists>u. S u \<and> f u) \<and> (\<forall>u. S u \<longrightarrow> f u \<longrightarrow> g u))
+     \<or> (\<forall>S. Sel x S \<longrightarrow> (\<forall>u. S u \<longrightarrow> \<not> f u))"
+definition validM :: "tau \<Rightarrow> bool" where "validM f \<equiv> \<forall>x. f x"
+
+section \<open>Mappings between the embeddings\<close>
+
+primrec dpToMax :: "cpl \<Rightarrow> sigma" where
+  "dpToMax (Atm p)    = AtmS p"
+| "dpToMax TopD       = TopS"
+| "dpToMax BotD       = BotS"
+| "dpToMax (NegD f)   = NegS (dpToMax f)"
+| "dpToMax (AndD f g) = AndS (dpToMax f) (dpToMax g)"
+| "dpToMax (OrD f g)  = OrS (dpToMax f) (dpToMax g)"
+| "dpToMax (ImpD f g) = ImpS (dpToMax f) (dpToMax g)"
+| "dpToMax (IffD f g) = IffS (dpToMax f) (dpToMax g)"
+| "dpToMax (CondD f g) = CondS (dpToMax f) (dpToMax g)"
+
+primrec dpToMin :: "cpl \<Rightarrow> tau" where
+  "dpToMin (Atm p)    = AtmM p"
+| "dpToMin TopD       = TopM"
+| "dpToMin BotD       = BotM"
+| "dpToMin (NegD f)   = NegM (dpToMin f)"
+| "dpToMin (AndD f g) = AndM (dpToMin f) (dpToMin g)"
+| "dpToMin (OrD f g)  = OrM (dpToMin f) (dpToMin g)"
+| "dpToMin (ImpD f g) = ImpM (dpToMin f) (dpToMin g)"
+| "dpToMin (IffD f g) = IffM (dpToMin f) (dpToMin g)"
+| "dpToMin (CondD f g) = CondM (dpToMin f) (dpToMin g)"
+
+section \<open>Faithfulness (machine-checked by Isabelle's kernel)\<close>
+
+lemmas maxdefs = AtmS_def TopS_def BotS_def NegS_def AndS_def OrS_def
+                 ImpS_def IffS_def CondS_def
+lemmas mindefs = AtmM_def TopM_def BotM_def NegM_def AndM_def OrM_def
+                 ImpM_def IffM_def CondM_def
+
+text \<open>Deep truth coincides pointwise with maximal-shallow truth.\<close>
+theorem faithful1a: "truthD W Sp V x f = dpToMax f W Sp V x"
+  by (induct f arbitrary: x) (simp_all add: maxdefs)
+
+text \<open>Hence deep validity coincides with maximal-shallow validity.\<close>
+theorem faithful1b: "validD f = validS (dpToMax f)"
+  by (simp add: validD_def validS_def faithful1a)
+
+text \<open>Deep truth in the fixed model coincides with minimal-shallow truth.\<close>
+theorem faithful2: "truthD (\<lambda>_. True) Sel Vval x f = dpToMin f x"
+  by (induct f arbitrary: x) (simp_all add: mindefs)
+
+text \<open>Maximal- and minimal-shallow truth coincide in that fixed model.\<close>
+theorem faithful3: "dpToMax f (\<lambda>_. True) Sel Vval x = dpToMin f x"
+  by (induct f arbitrary: x) (simp_all add: maxdefs mindefs)
+
+text \<open>Soundness of the minimal embedding for deep validity (under the nesting
+      assumption the minimal embedding fixes as a const).\<close>
+theorem sound_min: "nested Sel \<Longrightarrow> validD f \<Longrightarrow> validM (dpToMin f)"
+proof -
+  assume ne: "nested Sel" and *: "validD f"
+  have "truthD (\<lambda>_. True) Sel Vval x f" for x
+    using * ne by (simp add: validD_def)
+  then show "validM (dpToMin f)"
+    by (simp add: validM_def faithful2)
+qed'''
+
+
+# --------------------------------------------------------------------------- #
+# Encoder + public entry point.
+# --------------------------------------------------------------------------- #
+
+# Boolean base (classical, per world); the counterfactual is built explicitly from
+# an antecedent/consequent pair — there is no counterfactual node in the AST.
+_BOOL_CTORS = {
+    Not: ("NegD", 1), And: ("AndD", 2), Or: ("OrD", 2),
+    Implies: ("ImpD", 2), Iff: ("IffD", 2),
+}
+
+
+def counterfactual_to_deep(antecedent: Node, consequent: Node,
+                           atoms: AtomConsts, kind: str = "would") -> str:
+    r"""Encode a counterfactual as a deep ``cpl`` term.
+
+    ``kind="would"`` builds ``(CondD <a> <b>)`` (``a \<box>\<rightarrow> b``); ``kind="might"``
+    builds ``(NegD (CondD <a> (NegD <b>)))`` (``a \<diamond>\<rightarrow> b \<equiv> \<not>(a \<box>\<rightarrow> \<not>b)``).
+    Antecedent and consequent are **propositional** (atoms + Boolean connectives),
+    matching :func:`unicode_logic_kit.semantics.conditional.would`.
+    """
+    a = encode_deep(antecedent, atoms, _BOOL_CTORS, logic="counterfactual_to_deep")
+    b = encode_deep(consequent, atoms, _BOOL_CTORS, logic="counterfactual_to_deep")
+    if kind == "would":
+        return f"(CondD {a} {b})"
+    if kind == "might":
+        return f"(NegD (CondD {a} (NegD {b})))"
+    raise ValueError(f"counterfactual_to_deep: kind must be 'would' or 'might', got {kind!r}.")
+
+
+def conditional_faithfulness_theory(
+    theory_name: str = "CondFaithfulness",
+    antecedent: Optional[Node] = None,
+    consequent: Optional[Node] = None,
+    kind: str = "would",
+) -> str:
+    r"""Emit the self-contained Lewis-conditional deep/maximal/minimal + faithfulness theory.
+
+    When both ``antecedent`` and ``consequent`` are given, the corresponding
+    counterfactual (``kind`` ``"would"`` / ``"might"``) is appended as
+    ``definition example :: cpl``. With a local Isabelle/HOL the theory is verified
+    end to end by :func:`unicode_logic_kit.hol.isabelle_runner.check_theory`.
+    """
+    extra = ""
+    if antecedent is not None and consequent is not None:
+        atoms = AtomConsts()
+        term = counterfactual_to_deep(antecedent, consequent, atoms, kind=kind)
+        extra = formula_section(term, atoms, "cpl")
+    elif (antecedent is None) != (consequent is None):
+        raise ValueError(
+            "conditional_faithfulness_theory: pass both antecedent and consequent, or neither.")
+    return wrap_theory(theory_name, _COND_BODY, extra)

unicode_logic_kit/hol/deepshallow/intuitionistic.py

@@ -0,0 +1,181 @@
+r"""Deep + maximal-shallow + minimal-shallow embeddings of **intuitionistic
+propositional logic** (Kripke semantics), with machine-checked faithfulness proofs.
+
+The accessibility relation is a preorder ``\<le>`` (``preorder``) and the valuation is
+persistent (``monotone``); ``\<rightarrow>`` and ``\<not>`` quantify over ``\<le>``-successors, matching
+the toolkit's :func:`unicode_logic_kit.semantics.intuitionistic.int_valid`. As in the
+modal case, ``faithful1a/1b/2/3`` relate the three embeddings; here ``sound_min``
+carries the two frame hypotheses (the minimal embedding fixes ``\<le>`` and ``V`` as
+metalogical ``consts``, so their preorder/persistence must be assumed, not derived).
+"""
+
+from typing import Optional
+
+from unicode_logic_kit.fol.nodes import Node, Not, And, Or, Implies, Iff
+from ._common import AtomConsts, encode_deep, wrap_theory, formula_section
+
+# --------------------------------------------------------------------------- #
+# Verified theory body (checked verbatim by the Isabelle-gated tests).
+# --------------------------------------------------------------------------- #
+
+_INT_BODY = r'''typedecl w  \<comment> \<open>worlds\<close>
+typedecl s  \<comment> \<open>signature: propositional symbols (shared by all three embeddings)\<close>
+type_synonym wset = "w \<Rightarrow> bool"
+type_synonym acc  = "w \<Rightarrow> w \<Rightarrow> bool"    \<comment> \<open>the accessibility preorder \<le>\<close>
+type_synonym val  = "s \<Rightarrow> w \<Rightarrow> bool"
+
+definition preorder :: "acc \<Rightarrow> bool" where
+  "preorder L \<equiv> (\<forall>x. L x x) \<and> (\<forall>x y z. L x y \<longrightarrow> L y z \<longrightarrow> L x z)"
+definition monotone :: "acc \<Rightarrow> val \<Rightarrow> bool" where
+  "monotone L V \<equiv> \<forall>p x y. L x y \<longrightarrow> V p x \<longrightarrow> V p y"
+
+section \<open>Deep embedding: object syntax as a datatype + recursive truth\<close>
+
+datatype ipl =
+    Atm s | TopD | BotD
+  | NegD ipl | AndD ipl ipl | OrD ipl ipl | ImpD ipl ipl | IffD ipl ipl
+
+primrec truthD :: "wset \<Rightarrow> acc \<Rightarrow> val \<Rightarrow> w \<Rightarrow> ipl \<Rightarrow> bool" where
+  "truthD W L V x (Atm p)    = V p x"
+| "truthD W L V x TopD       = True"
+| "truthD W L V x BotD       = False"
+| "truthD W L V x (AndD f g) = (truthD W L V x f \<and> truthD W L V x g)"
+| "truthD W L V x (OrD f g)  = (truthD W L V x f \<or> truthD W L V x g)"
+| "truthD W L V x (NegD f)   = (\<forall>y. L x y \<longrightarrow> \<not> truthD W L V y f)"
+| "truthD W L V x (ImpD f g) = (\<forall>y. L x y \<longrightarrow> truthD W L V y f \<longrightarrow> truthD W L V y g)"
+| "truthD W L V x (IffD f g) = ((\<forall>y. L x y \<longrightarrow> truthD W L V y f \<longrightarrow> truthD W L V y g)
+                              \<and> (\<forall>y. L x y \<longrightarrow> truthD W L V y g \<longrightarrow> truthD W L V y f))"
+
+definition validD :: "ipl \<Rightarrow> bool" where
+  "validD f \<equiv> \<forall>W L V. preorder L \<longrightarrow> monotone L V \<longrightarrow> (\<forall>x. W x \<longrightarrow> truthD W L V x f)"
+
+section \<open>Maximal (heavyweight) shallow embedding: every parameter explicit\<close>
+
+type_synonym sigma = "wset \<Rightarrow> acc \<Rightarrow> val \<Rightarrow> w \<Rightarrow> bool"
+definition AtmS :: "s \<Rightarrow> sigma" where "AtmS p \<equiv> \<lambda>W L V x. V p x"
+definition TopS :: "sigma" where "TopS \<equiv> \<lambda>W L V x. True"
+definition BotS :: "sigma" where "BotS \<equiv> \<lambda>W L V x. False"
+definition AndS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "AndS f g \<equiv> \<lambda>W L V x. f W L V x \<and> g W L V x"
+definition OrS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "OrS f g \<equiv> \<lambda>W L V x. f W L V x \<or> g W L V x"
+definition NegS :: "sigma \<Rightarrow> sigma" where
+  "NegS f \<equiv> \<lambda>W L V x. \<forall>y. L x y \<longrightarrow> \<not> f W L V y"
+definition ImpS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "ImpS f g \<equiv> \<lambda>W L V x. \<forall>y. L x y \<longrightarrow> f W L V y \<longrightarrow> g W L V y"
+definition IffS :: "sigma \<Rightarrow> sigma \<Rightarrow> sigma" where
+  "IffS f g \<equiv> \<lambda>W L V x. (\<forall>y. L x y \<longrightarrow> f W L V y \<longrightarrow> g W L V y)
+                       \<and> (\<forall>y. L x y \<longrightarrow> g W L V y \<longrightarrow> f W L V y)"
+definition validS :: "sigma \<Rightarrow> bool" where
+  "validS f \<equiv> \<forall>W L V. preorder L \<longrightarrow> monotone L V \<longrightarrow> (\<forall>x. W x \<longrightarrow> f W L V x)"
+
+section \<open>Minimal (lightweight) shallow embedding: \<le>, V fixed as metalogical consts\<close>
+
+consts Leq :: "acc"
+consts Vval :: "val"
+type_synonym tau = "w \<Rightarrow> bool"
+definition AtmM :: "s \<Rightarrow> tau" where "AtmM p \<equiv> \<lambda>x. Vval p x"
+definition TopM :: "tau" where "TopM \<equiv> \<lambda>x. True"
+definition BotM :: "tau" where "BotM \<equiv> \<lambda>x. False"
+definition AndM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where "AndM f g \<equiv> \<lambda>x. f x \<and> g x"
+definition OrM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where "OrM f g \<equiv> \<lambda>x. f x \<or> g x"
+definition NegM :: "tau \<Rightarrow> tau" where "NegM f \<equiv> \<lambda>x. \<forall>y. Leq x y \<longrightarrow> \<not> f y"
+definition ImpM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where
+  "ImpM f g \<equiv> \<lambda>x. \<forall>y. Leq x y \<longrightarrow> f y \<longrightarrow> g y"
+definition IffM :: "tau \<Rightarrow> tau \<Rightarrow> tau" where
+  "IffM f g \<equiv> \<lambda>x. (\<forall>y. Leq x y \<longrightarrow> f y \<longrightarrow> g y) \<and> (\<forall>y. Leq x y \<longrightarrow> g y \<longrightarrow> f y)"
+definition validM :: "tau \<Rightarrow> bool" where "validM f \<equiv> \<forall>x. f x"
+
+section \<open>Mappings between the embeddings\<close>
+
+primrec dpToMax :: "ipl \<Rightarrow> sigma" where
+  "dpToMax (Atm p)    = AtmS p"
+| "dpToMax TopD       = TopS"
+| "dpToMax BotD       = BotS"
+| "dpToMax (NegD f)   = NegS (dpToMax f)"
+| "dpToMax (AndD f g) = AndS (dpToMax f) (dpToMax g)"
+| "dpToMax (OrD f g)  = OrS (dpToMax f) (dpToMax g)"
+| "dpToMax (ImpD f g) = ImpS (dpToMax f) (dpToMax g)"
+| "dpToMax (IffD f g) = IffS (dpToMax f) (dpToMax g)"
+
+primrec dpToMin :: "ipl \<Rightarrow> tau" where
+  "dpToMin (Atm p)    = AtmM p"
+| "dpToMin TopD       = TopM"
+| "dpToMin BotD       = BotM"
+| "dpToMin (NegD f)   = NegM (dpToMin f)"
+| "dpToMin (AndD f g) = AndM (dpToMin f) (dpToMin g)"
+| "dpToMin (OrD f g)  = OrM (dpToMin f) (dpToMin g)"
+| "dpToMin (ImpD f g) = ImpM (dpToMin f) (dpToMin g)"
+| "dpToMin (IffD f g) = IffM (dpToMin f) (dpToMin g)"
+
+section \<open>Faithfulness (machine-checked by Isabelle's kernel)\<close>
+
+lemmas maxdefs = AtmS_def TopS_def BotS_def NegS_def AndS_def OrS_def ImpS_def IffS_def
+lemmas mindefs = AtmM_def TopM_def BotM_def NegM_def AndM_def OrM_def ImpM_def IffM_def
+
+text \<open>Deep truth coincides pointwise with maximal-shallow truth.\<close>
+theorem faithful1a: "truthD W L V x f = dpToMax f W L V x"
+  by (induct f arbitrary: x) (simp_all add: maxdefs)
+
+text \<open>Hence deep validity coincides with maximal-shallow validity.\<close>
+theorem faithful1b: "validD f = validS (dpToMax f)"
+  by (simp add: validD_def validS_def faithful1a)
+
+text \<open>Deep truth in the fixed model coincides with minimal-shallow truth.\<close>
+theorem faithful2: "truthD (\<lambda>_. True) Leq Vval x f = dpToMin f x"
+  by (induct f arbitrary: x) (simp_all add: mindefs)
+
+text \<open>Maximal- and minimal-shallow truth coincide in that fixed model.\<close>
+theorem faithful3: "dpToMax f (\<lambda>_. True) Leq Vval x = dpToMin f x"
+  by (induct f arbitrary: x) (simp_all add: maxdefs mindefs)
+
+text \<open>Soundness of the minimal embedding for deep validity (under the frame
+      assumptions the minimal embedding fixes as consts).\<close>
+theorem sound_min:
+  "preorder Leq \<Longrightarrow> monotone Leq Vval \<Longrightarrow> validD f \<Longrightarrow> validM (dpToMin f)"
+proof -
+  assume pre: "preorder Leq" and mono: "monotone Leq Vval" and *: "validD f"
+  have "truthD (\<lambda>_. True) Leq Vval x f" for x
+    using * pre mono by (simp add: validD_def)
+  then show "validM (dpToMin f)"
+    by (simp add: validM_def faithful2)
+qed'''
+
+
+# --------------------------------------------------------------------------- #
+# Encoder + public entry point.
+# --------------------------------------------------------------------------- #
+
+# Intuitionistic propositional connectives (no modalities; Xor is not admitted).
+_CTORS = {
+    Not: ("NegD", 1), And: ("AndD", 2), Or: ("OrD", 2),
+    Implies: ("ImpD", 2), Iff: ("IffD", 2),
+}
+
+
+def int_to_deep(formula: Node, atoms: AtomConsts) -> str:
+    r"""Encode a **propositional intuitionistic** formula as a deep ``ipl`` term.
+
+    Maps ``\<not> \<and> \<or> \<rightarrow> \<leftrightarrow>`` and atoms; raises :class:`NotImplementedError` on
+    modalities, ``Xor``, quantifiers, or free variables (the deep embedding is
+    propositional intuitionistic).
+    """
+    return encode_deep(formula, atoms, _CTORS, logic="int_to_deep", allow_xor=False)
+
+
+def intuitionistic_faithfulness_theory(
+    theory_name: str = "IntFaithfulness",
+    formula: Optional[Node] = None,
+) -> str:
+    r"""Emit the self-contained intuitionistic deep/maximal/minimal + faithfulness theory.
+
+    See :func:`unicode_logic_kit.hol.deepshallow.modal.modal_faithfulness_theory`; this
+    is the intuitionistic-Kripke counterpart. With a local Isabelle/HOL it is verified
+    end to end by :func:`unicode_logic_kit.hol.isabelle_runner.check_theory`.
+    """
+    extra = ""
+    if formula is not None:
+        atoms = AtomConsts()
+        term = int_to_deep(formula, atoms)
+        extra = formula_section(term, atoms, "ipl")
+    return wrap_theory(theory_name, _INT_BODY, extra)