cubical-transport-hott-lean4/Topolei/Selection.lean

/-
  Topolei.Selection
  =================
  Foundational selection abstraction — hypothesis stack H1 + H2.

  ## What's a hypothesis here

  The user's design intent:

    "Selection has to live in cell space as a cell abstraction.
     We want a stack of options... navigate a selection path.
     Observation returns results we use the observation on again.
     The space [we navigate] must match the space we are in."

  My natural-transformation reading: a Selection is a *focus inside
  a cell-tree with history*.  The tree structure is the cell space;
  the focus is "where we currently are"; the history is "how we got
  here".  Mathematically: a **zipper** (Huet 1997).

  ## The two hypotheses this file commits to

  **H1 — Selection is a focused sub-cell with breadcrumb history.**
  A `Selection` carries a `focus : WCell` and a `crumbs : List Crumb`
  trail.  `read` returns the focus.  Round-trip: `descend i` then
  `ascend` is the identity (when descend succeeded), so the trail
  faithfully encodes the path back to the root.

  **H2 — Path application is associative.**  Building selections by
  composing `Move`s is associative: `applyPath s (p₁ ++ p₂) =
  (applyPath s p₁) >>= (·.applyPath p₂)`.  Identity move-list is
  the unit.  Together these say `(Selection, applyPath, [], ++)` is
  a partial monoid action by the move-monoid.

  ## What this is NOT yet

  - H3 (Boolean algebra ∩, ∪, ¬ over `σ`-predicates) — selections as
    sub-objects beyond focus;
  - H4 (horizontal lifts) — selections that follow the connection on
    the fibration;
  - H5 (trace map) — inverse projection from rendered elements back
    to source morphisms.

  Each of those is a separate file once H1+H2 are stable.

  ## Why no Rust

  This is structural reasoning about a Lean inductive.  The
  zipper's correctness is decided by Lean's kernel from the
  definitions; nothing here needs to execute on a GPU.  When
  selections eventually drive the renderer, the existing
  `compileEMLPath` pipeline consumes the *focus* of a selection
  (a single cell) and runs unchanged.
-/

namespace Topolei.Selection

-- ── Workspace cell ─────────────────────────────────────────────────────────
--
-- A minimal labeled tree.  Stand-in for the broader cell calculus —
-- when the cubical Cell type stabilises, concrete cells (EMLPath,
-- CTerm, …) project into this structure for selection purposes via
-- a `toWCell` function we'll add per-cell-type.  The selection
-- algebra here doesn't care about the cell's interior, only its
-- tree shape.

inductive WCell where
  | mk : String → List WCell → WCell
deriving Inhabited

namespace WCell

def data : WCell → String
  | .mk d _ => d

def children : WCell → List WCell
  | .mk _ c => c

@[simp] theorem mk_data (d : String) (cs : List WCell) :
    (WCell.mk d cs).data = d := rfl

@[simp] theorem mk_children (d : String) (cs : List WCell) :
    (WCell.mk d cs).children = cs := rfl

@[simp] theorem eta : ∀ c : WCell, WCell.mk c.data c.children = c
  | .mk _ _ => rfl

end WCell

-- ── Crumb (one step of breadcrumb trail) ──────────────────────────────────
--
-- When we descend from a parent into its i-th child, we leave a
-- breadcrumb that records: the parent's data + the index we took +
-- the parent's full children list.  Reconstructing the parent from
-- the (possibly modified) child = `set`-replacing the i-th slot
-- with the focus.
--
-- Storing the whole `parentChildren` list is more memory than
-- splitting into (left, right) but makes reconstruction equationally
-- clean and the round-trip proof a one-liner via `List.set_get?_eq`.

structure Crumb where
  parentData     : String
  index          : Nat
  parentChildren : List WCell
deriving Inhabited

namespace Crumb

/-- Reconstruct the parent cell from a focused child + this breadcrumb. -/
def reconstruct (cr : Crumb) (child : WCell) : WCell :=
  WCell.mk cr.parentData (cr.parentChildren.set cr.index child)

end Crumb

-- ── Selection ─────────────────────────────────────────────────────────────

/-- A Selection: a focused cell + a breadcrumb trail back to the root.
    Trail's head is the immediate parent (most recent crumb); trail's
    last element is the root's parent (none — i.e., focus is root —
    when the trail is empty).

    Invariant we will *never* state in the type but is true by
    construction: `crumbs.head?.parentChildren[crumbs.head?.index]?` is
    the position the focus was descended into.  We don't carry this
    invariant in the type because it makes manipulation awkward; the
    `descend_ascend` theorem below proves it implicitly. -/
structure Selection where
  focus  : WCell
  crumbs : List Crumb
deriving Inhabited

namespace Selection

/-- The trivial selection at the root of `c`: focus = c, empty trail. -/
def atRoot (c : WCell) : Selection := { focus := c, crumbs := [] }

/-- Read the currently-focused cell. -/
def read (s : Selection) : WCell := s.focus

-- ── H1.1: round-trip on `atRoot` ──────────────────────────────────────────

/-- Reading the at-root selection of `c` returns `c`.  This is the
    most basic round-trip: the trivial selection of a cell faithfully
    represents the cell. -/
@[simp] theorem atRoot_read (c : WCell) : (atRoot c).read = c := rfl

-- ── Navigation: descend / ascend ──────────────────────────────────────────

/-- Descend into the i-th child of the focus.  Returns `none` if `i`
    is out of range — the user can then handle the failure
    however the calling layer prefers. -/
def descend (s : Selection) (i : Nat) : Option Selection :=
  match s.focus.children[i]? with
  | none       => none
  | some child =>
      some { focus  := child
             crumbs := { parentData     := s.focus.data
                         index          := i
                         parentChildren := s.focus.children } :: s.crumbs }

/-- Ascend back to the parent.  Returns `none` if the focus IS the
    root (empty crumbs). -/
def ascend (s : Selection) : Option Selection :=
  match s.crumbs with
  | []         => none
  | cr :: rest => some { focus := cr.reconstruct s.focus, crumbs := rest }

-- ── H1.2: descend-then-ascend = identity ──────────────────────────────────

/-- The key list-set lemma we need for `descend_ascend`: if `l[i]? =
    some x`, then `l.set i x = l`.  Replacing an element at a position
    with the same element it already had is a no-op.  Proved by
    induction; standalone because the exact name in the Lean stdlib
    has churned across versions. -/
private theorem List.set_self_of_getElem? {α : Type _}
    : ∀ {l : List α} {i : Nat} {x : α}, l[i]? = some x → l.set i x = l
  | [],      _,     _, h => by simp at h
  | _ :: _,  0,     _, h => by simp at h; subst h; rfl
  | _ :: tl, i+1,   _, h => by
      simp [List.set]
      exact List.set_self_of_getElem? (l := tl) (by simpa using h)

/-- **H1.2 — descend-then-ascend round-trip.**  If descending into
    child `i` succeeded, ascending from the result returns the
    original selection.

    The proof:  `descend` produces a selection whose focus is the
    i-th child and whose top crumb stores the parent's children
    list.  `ascend` reconstructs the parent by `set`-replacing
    position `i` with the focus.  Since the focus IS the i-th
    child (it's what we descended into), `set i child` is a no-op
    on `parentChildren`, giving back the original parent. -/
theorem descend_ascend (s : Selection) (i : Nat) (s' : Selection)
    (h : s.descend i = some s') : s'.ascend = some s := by
  -- Unpack `descend` to extract the child + the structure of s'.
  unfold descend at h
  match hChild : s.focus.children[i]? with
  | none =>
      rw [hChild] at h
      contradiction
  | some child =>
      rw [hChild] at h
      -- Now h : some {focus := child, crumbs := newCrumb :: s.crumbs} = some s'
      injection h with h'
      subst h'
      -- Goal: ascend (the_descended_selection) = some s
      simp only [ascend, Crumb.reconstruct]
      -- The goal reduces to:
      --   { focus := WCell.mk s.focus.data (s.focus.children.set i child),
      --     crumbs := s.crumbs } = s
      -- which follows from `set i child = s.focus.children` (since
      -- `child = s.focus.children[i]`) plus WCell.eta on s.focus.
      rw [List.set_self_of_getElem? hChild]
      simp [WCell.eta]

-- ── Composition: Move + Path + applyPath ──────────────────────────────────

/-- A single navigation step. -/
inductive Move where
  | descend : Nat → Move
  | ascend  : Move
deriving Repr, Inhabited

/-- Apply a single move.  `descend i` may fail if `i` is out of
    range; `ascend` may fail if focus is root. -/
def applyMove (s : Selection) : Move → Option Selection
  | .descend i => s.descend i
  | .ascend    => s.ascend

/-- Apply a sequence of moves left-to-right.  Threads `Option`
    through the fold — any failed move aborts the whole path. -/
def applyPath : Selection → List Move → Option Selection
  | s, []      => some s
  | s, m :: ms => (applyMove s m).bind (·.applyPath ms)

-- ── H2.1: identity ────────────────────────────────────────────────────────

/-- The empty path is the identity. -/
@[simp] theorem applyPath_nil (s : Selection) : applyPath s [] = some s := rfl

-- ── H2.2: associativity ───────────────────────────────────────────────────

/-- **H2 — applying a concatenated path = applying the parts in
    order.**  This is the partial-monoid associativity for the
    selection action.  The proof is induction on the first list,
    pushing the bind through. -/
theorem applyPath_append (s : Selection) (p₁ p₂ : List Move) :
    applyPath s (p₁ ++ p₂) = (applyPath s p₁).bind (·.applyPath p₂) := by
  induction p₁ generalizing s with
  | nil => simp [applyPath]
  | cons m ms ih =>
      simp only [List.cons_append, applyPath]
      cases applyMove s m with
      | none      => simp
      | some s'   => simp [ih]

-- ── Concrete demo (operational sanity check via `#eval`) ──────────────────

/-- A small example tree:
        root [ inner [ leaf-A, leaf-B ], leaf-C ]
    Used by `#eval`s below.  We use `#eval`-style introspection
    rather than `decide`-backed example proofs because the
    Decidable instance for `Selection` doesn't reduce in the
    elaborator (it's defined on a recursive `WCell.mk` and the
    elaborator gets stuck on `sorry`-mocking unwound recursion).
    The abstract theorems above are what actually verify the
    abstraction; these `#eval`s just let a human eyeball that
    operations behave as expected. -/
def demoTree : WCell :=
  WCell.mk "root"
    [ WCell.mk "inner"
        [ WCell.mk "leaf-A" [], WCell.mk "leaf-B" [] ]
    , WCell.mk "leaf-C" []
    ]

/-- Descend twice into the "inner" child then "leaf-A".  The focused
    cell's data should be `"leaf-A"`. -/
def demoFocus : Option String :=
  ((applyPath (atRoot demoTree) [.descend 0, .descend 0]).map (·.read.data))

#eval demoFocus -- expected: some "leaf-A"

/-- Round-trip check: descend into the inner cell, ascend, focus's
    data should be `"root"` (the original root). -/
def demoRoundTrip : Option String :=
  (((atRoot demoTree).descend 0).bind (·.ascend)).map (·.read.data)

#eval demoRoundTrip -- expected: some "root"

end Selection
end Topolei.Selection