diff --git a/differential/src/bin/pruned_trace.rs b/differential/src/bin/pruned_trace.rs new file mode 100644 index 00000000..9f066582 --- /dev/null +++ b/differential/src/bin/pruned_trace.rs @@ -0,0 +1,36 @@ +//! Prints the dangling-path-free differential trace for a fuzzer input, from +//! the real crate. +//! +//! pruned_trace # or read the bytes from stdin +//! +//! `lean/.lake/build/bin/pruned-oracle` prints the same trace from +//! `PrunedModel`; `lean/pruned_differential.py` runs both and diffs them. +//! +//! `--check` needs no oracle: it asserts the zipper invariants after every +//! operation and, at the end of the run, that the write target contains no +//! dangling path -- which is the whole claim this harness's operation subset +//! makes. See `differential::pruned`. + +use differential::pruned::run; +use differential::serve; + +fn main() { + let args: Vec = std::env::args().skip(1).collect(); + let check = args.iter().any(|a| a == "--check"); + // Resident mode: one process, many inputs over stdin. See `serve`. + if args.iter().any(|a| a == "--server") { + serve(check, run); + return; + } + let file = args.iter().find(|a| !a.starts_with("--")).cloned(); + let bytes: Vec = match file { + Some(p) => std::fs::read(p).expect("cannot read input"), + None => { + use std::io::Read; + let mut v = Vec::new(); + std::io::stdin().read_to_end(&mut v).unwrap(); + v + } + }; + print!("{}", run(&bytes, check)); +} diff --git a/differential/src/harness.rs b/differential/src/harness.rs index 2958cb4e..ebf63ff2 100644 --- a/differential/src/harness.rs +++ b/differential/src/harness.rs @@ -62,6 +62,11 @@ impl<'a> Dec<'a> { }; Some(Self { bytes, pos, op_count }) } + /// A decoder with no header handling, for streams whose caller picks the + /// operation itself (the pruned fuzzer). + pub fn legacy(bytes: &'a [u8]) -> Self { + Self { bytes, pos: 0, op_count: LEGACY_NOPS } + } pub fn op(&mut self) -> Option { self.modn(self.op_count) } @@ -175,18 +180,14 @@ pub fn fingerprint + ZipperAbso /// implement the trait the op needs. /// * `skip:at-root` — `to_next`/`to_prev_sibling_byte` at the zipper root, /// where the native read zipper escapes its own root. -/// * `skip:k0` — a degenerate `k = 0` on `join`/`meet_k_path_into`. /// * `skip:empty-focus` — the focus has nothing below it, where the op's /// behaviour is a function of node materialisation rather than trie state. -/// * `skip:empty-path` — `insert_prefix("")`, which destroys the subtrie. /// * `skip:quarantined` — the op is disabled outright (op 54). /// /// Each is recorded in lean/FINDINGS.md and commented at its site. pub const SKIP_ACT: &str = "skip:act"; pub const SKIP_AT_ROOT: &str = "skip:at-root"; -pub const SKIP_K0: &str = "skip:k0"; pub const SKIP_EMPTY_FOCUS: &str = "skip:empty-focus"; -pub const SKIP_EMPTY_PATH: &str = "skip:empty-path"; pub const SKIP_QUARANTINED: &str = "skip:quarantined"; /// Does the focus have no descendants at all? @@ -776,28 +777,18 @@ pub fn run_ops( 42 => { let k = get!(d.modn(4)); let pr = get!(d.boolean()); - // `join_k_path_into(0)` destroys the subtrie in pathmap 0.3.1. - if k == 0 { - ("join_k_path_into", SKIP_K0.to_string()) + // The bool leaks node materialisation; see FINDINGS.md #8. + let r = wz.join_k_path_into(k, pr); + let s = if focus_node_empty(&wz) { + "?".to_string() } else { - // The bool leaks node materialisation; see FINDINGS.md #8. - let r = wz.join_k_path_into(k, pr); - let s = if focus_node_empty(&wz) { - "?".to_string() - } else { - show_bool(r).to_string() - }; - ("join_k_path_into", s) - } + show_bool(r).to_string() + }; + ("join_k_path_into", s) } 43 => { let p = get!(d.path(6)); - // `insert_prefix("")` destroys the subtrie in pathmap 0.3.1. - if p.is_empty() { - ("insert_prefix", SKIP_EMPTY_PATH.to_string()) - } else { - ("insert_prefix", show_bool(wz.insert_prefix(&p)).to_string()) - } + ("insert_prefix", show_bool(wz.insert_prefix(&p)).to_string()) } 44 => { let n = get!(d.modn(6)); @@ -818,19 +809,7 @@ pub fn run_ops( 46 => { let k = get!(d.modn(4)); let pr = get!(d.boolean()); - // `meet_k_path_into` spins forever when the focus has no - // children, and escapes the focus subtree when k == 0. - // See `Zip.meetKPathUnspecified`. - if k == 0 { - ("meet_k_path_into", SKIP_K0.to_string()) - } else if wz.child_count() == 0 { - ("meet_k_path_into", SKIP_EMPTY_FOCUS.to_string()) - } else { - ( - "meet_k_path_into", - show_bool(wz.meet_k_path_into(k, pr)).to_string(), - ) - } + ("meet_k_path_into", show_bool(wz.meet_k_path_into(k, pr)).to_string()) } 48 => { let v = get!(d.u8()) as u64; diff --git a/differential/src/lib.rs b/differential/src/lib.rs index 661cf803..e546ea72 100644 --- a/differential/src/lib.rs +++ b/differential/src/lib.rs @@ -8,9 +8,14 @@ //! * [`server`] is the resident-process protocol the driver speaks. //! * [`repro`] turns an input back into standalone `pathmap` calls. //! * [`act`] is the `ArenaCompactTree` read source behind `act_trace`. +//! * [`pruned`] is a second, smaller harness: the subset of the API that +//! cannot leave a dangling path, checked against `lean/PrunedModel` and +//! driven by `lean/pruned_differential.py`. See its module docs for why it +//! is not `harness` with a flag. pub mod act; pub mod harness; +pub mod pruned; pub mod repro; pub mod server; diff --git a/differential/src/pruned.rs b/differential/src/pruned.rs new file mode 100644 index 00000000..47f7d86e --- /dev/null +++ b/differential/src/pruned.rs @@ -0,0 +1,588 @@ +//! The crate side of the **dangling-path-free** differential harness. +//! +//! `lean/.lake/build/bin/pruned-oracle` prints the same trace from +//! `PrunedModel`; `lean/pruned_differential.py` runs both and diffs them. The +//! wire format and operation table are a contract shared with +//! `lean/PrunedModel/Fuzz.lean`; any change here must be mirrored there. +//! +//! This is not [`crate::harness`] with a flag. That harness explores the whole +//! zipper API and reproduces whatever `pathmap` does with dangling paths; its +//! prune flags are pinned to `false` and compared against nothing, because the +//! flag's effect is a function of where an internal node boundary happens to +//! fall. This one explores a smaller API and makes a stronger claim about it: +//! +//! 1. **No `create_path`.** Its whole purpose is a location with no value. +//! 2. **`prune = true` everywhere**, and `prune_path` / `prune_ascend` stay in +//! the table as assertions: the model says `0`, so a non-zero count means +//! something in the subset leaked a dangling path for it to find. +//! 3. **The write zipper is rooted at the map root.** A write zipper rooted +//! below it holds a node at its own root, which survives as a location +//! leading nowhere once everything beneath it is removed, and `prune_path` +//! does not rise above the zipper's origin. Off-root *writing* is still +//! covered: the root-rooted zipper reaches every focus with `descend_to`. +//! +//! There is one read source, a `PathMap` read zipper, so no `ReadSource` trait +//! and no ACT mode — `graft_child_maps`, quarantined in the other harness, is +//! simply not in this table. +//! +//! `--check` adds in-process assertions needing no oracle: the zipper +//! invariants from [`crate::harness::check_zipper`], plus the one this harness +//! is named for — [`check_no_dangling`]. + +use pathmap::PathMap; +use pathmap::utils::ByteMask; +use pathmap::zipper::*; + +use crate::harness::{ + check_zipper, dump, fingerprint, hex_path, show_bool, show_byte_opt, show_status, show_val, + Dec, MAX_STEPS, +}; + +use core::fmt::Write as _; + +/// Number of distinct operations. Must match `PrunedModel.Fuzz.nops`. +pub const NOPS: usize = 54; + +/// Why an operation was skipped. Every `skip` in the trace carries one of +/// these. `lean/PrunedModel/Fuzz.lean` emits the same tokens; the two must +/// agree exactly or every input with a skip diverges. +/// +/// Note which reasons from [`crate::harness`] are *absent*: `skip:act` (there is +/// one read source here), `skip:off-root-prune` (the write zipper is always at +/// the map root, so the prune count is well-defined), and `skip:quarantined` +/// (`graft_child_maps` is not in this table). +/// +/// `to_next`/`to_prev_sibling_byte` at the zipper root, where the native read +/// zipper escapes its own root. +pub const SKIP_AT_ROOT: &str = "skip:at-root"; +/// The focus has nothing below it, where the op's behaviour is a function of +/// node materialisation rather than of trie state. +pub const SKIP_EMPTY_FOCUS: &str = "skip:empty-focus"; + +/// The prune flag every operation in this subset is driven with. +/// +/// The opposite of [`crate::harness`]'s `no_prune`, and for the same reason +/// stated the other way round: there, the flag's effect is unspecifiable, so it +/// is never exercised; here, removal is *defined* to reclaim the chain, so it is +/// always exercised and always compared. +const PRUNE: bool = true; + +/// Does the focus have no descendants at all? +/// +/// Several return values (`remove_branches`, `restricting`, `join_map_into`, +/// `take_map`, `restrict`) hinge on whether an *empty node* happens to be +/// materialised at the focus rather than on the logical state, so they are +/// masked here. +fn focus_node_empty(z: &Z) -> bool { + z.child_count() == 0 +} + +/// Canonical rendering of a decoded byte mask: ascending, deduplicated, which is +/// what `ByteMask.ofList` produces on the Lean side. +fn canon_mask(m: &[u8]) -> Vec { + let mut v = m.to_vec(); + v.sort_unstable(); + v.dedup(); + v +} + +/// **The invariant this harness is named for**: no location exists without +/// leading to a value. +/// +/// Walks the whole map and asserts that every location with no children carries +/// a value. The root of an empty map is the one exception — `PathMap::new()` +/// reports `path_exists() == true` at the root, and there is nothing it could +/// lead to. +/// +/// This needs no oracle, which makes it the cheapest way to run the subset: +/// `--check` asserts it after every operation, and a failure localises the +/// leaking operation to one step without a trace diff. +pub fn check_no_dangling(map: &PathMap, label: &str) { + let mut z = map.read_zipper(); + // `to_next_step` visits every location below the root in depth-first order; + // the root itself is checked by the `is_empty` escape above. + loop { + if z.child_count() == 0 && !z.is_val() { + panic!( + "{label}: dangling path at {} -- a location with no value and no children", + hex_path(z.path()) + ); + } + if !z.to_next_step() { + break; + } + } +} + +/// Decode the header: two seeded maps and the read zipper's root. +/// +/// The write zipper's root is not decoded — it is always the map root. The read +/// zipper's root is decoded as a path and then clamped to its longest existing +/// prefix, rather than created: `create_path` is not in this subset, and a +/// zipper whose root does not exist can walk out of it (lean/FINDINGS.md #3), +/// which would contaminate every other comparison. +pub fn decode_header(d: &mut Dec) -> Option<(PathMap, PathMap, Vec)> { + let mut m0 = PathMap::::new(); + let n0 = d.modn(8)?; + for _ in 0..n0 { + let p = d.path(6)?; + let v = d.u8()? as u64; + m0.set_val_at(&p, v); + } + let mut m1 = PathMap::::new(); + let n1 = d.modn(8)?; + for _ in 0..n1 { + let p = d.path(6)?; + let v = d.u8()? as u64; + m1.set_val_at(&p, v); + } + let raw = d.path(4)?; + // Existence is prefix-closed, so the prefixes that exist form an initial + // segment: stop at the first one that does not. `PrunedModel.Fuzz`'s + // `clampToExisting` is the same computation over the model. + let mut root1: Vec = Vec::new(); + for j in 1..=raw.len() { + if m1.read_zipper_at_path(&raw[..j]).path_exists() { + root1 = raw[..j].to_vec(); + } else { + break; + } + } + Some((m0, m1, root1)) +} + +/// Decode and execute a fuzzer input. +pub fn run(bytes: &[u8], check: bool) -> String { + let mut d = Dec::legacy(bytes); + let (mut map0, map1, root1) = match decode_header(&mut d) { + Some(x) => x, + None => return "EMPTY\n".to_string(), + }; + let mut out = String::new(); + { + // NOTE: `read_zipper_at_borrowed_path` would panic (release: wrap) in + // `to_next_k_path`, whose `path_len()` underflows before the path buffer + // is prepared. Use the owned-path constructor so that known bug does + // not abort every run. + let mut rz = map1.read_zipper_at_path(&root1); + run_ops(&mut d, &mut out, &mut map0, &mut rz, &root1, check); + } + // The check needs the whole map, which the live write zipper holds, so it + // runs here rather than per step. Localising a leak to one operation is the + // trace diff's job; this is the no-oracle path. + if check { + check_no_dangling(&map0, "map0"); + } + let _ = writeln!(out, "MAP0 {}", dump(&mut map0.read_zipper())); + let _ = writeln!(out, "MAP1 {}", dump(&mut map1.read_zipper())); + // Printed for trace compatibility with the other harness, and because a + // reader of a divergence wants to see both roots stated rather than inferred. + let _ = writeln!(out, "ROOT0 {}", hex_path(&[])); + let _ = writeln!(out, "ROOT1 {}", hex_path(&root1)); + out +} + +/// Bind `$z` to the write zipper (`t == 0`) or the read zipper, then run `$e`. +macro_rules! tgt { + ($t:expr, $wz:expr, $rz:expr, $z:ident, $e:expr) => { + if $t == 0 { + let $z = &mut $wz; + $e + } else { + let $z = &mut $rz; + $e + } + }; +} + +/// Run the operation table. +pub fn run_ops( + d: &mut Dec, + out: &mut String, + map0: &mut PathMap, + rz: &mut ReadZipperUntracked<'_, '_, u64>, + root1: &[u8], + check: bool, +) { + let mut wz = map0.write_zipper(); + let root0: &[u8] = &[]; + let mut step = 0usize; + + macro_rules! get { + ($e:expr) => { + match $e { + Some(x) => x, + None => break, + } + }; + } + + loop { + if step >= MAX_STEPS { + break; + } + let op = get!(d.u8()) as usize % NOPS; + let (name, ret): (&str, String) = match op { + // ## Movement and reading, on either zipper + 0 => { + let t = get!(d.modn(2)); + let p = get!(d.path(6)); + tgt!(t, wz, *rz, z, z.descend_to(&p)); + ("descend_to", hex_path(&p)) + } + 1 => { + let t = get!(d.modn(2)); + let b = get!(d.path_byte()); + tgt!(t, wz, *rz, z, z.descend_to_byte(b)); + ("descend_to_byte", format!("{b:02x}")) + } + 2 => { + let t = get!(d.modn(2)); + let n = get!(d.modn(8)); + let r = tgt!(t, wz, *rz, z, z.ascend(n)); + ("ascend", format!("{r}")) + } + 3 => { + let t = get!(d.modn(2)); + let r = tgt!(t, wz, *rz, z, z.ascend_byte()); + ("ascend_byte", show_bool(r).to_string()) + } + 4 => { + let t = get!(d.modn(2)); + tgt!(t, wz, *rz, z, z.reset()); + ("reset", "-".to_string()) + } + 5 => { + let t = get!(d.modn(2)); + let r = tgt!(t, wz, *rz, z, z.descend_first_byte()); + ("descend_first_byte", show_byte_opt(r)) + } + 6 => { + let t = get!(d.modn(2)); + let r = tgt!(t, wz, *rz, z, z.descend_last_byte()); + ("descend_last_byte", show_byte_opt(r)) + } + 7 => { + let t = get!(d.modn(2)); + let i = get!(d.modn(6)); + let r = tgt!(t, wz, *rz, z, z.descend_indexed_byte(i)); + ("descend_indexed_byte", show_byte_opt(r)) + } + 8 => { + let t = get!(d.modn(2)); + let r = tgt!(t, wz, *rz, z, z.descend_until()); + ("descend_until", show_bool(r).to_string()) + } + 9 => { + let t = get!(d.modn(2)); + let r = tgt!(t, wz, *rz, z, z.ascend_until()); + ("ascend_until", format!("{r}")) + } + 10 => { + let t = get!(d.modn(2)); + let r = tgt!(t, wz, *rz, z, z.ascend_until_branch()); + ("ascend_until_branch", format!("{r}")) + } + 11 => { + let t = get!(d.modn(2)); + // Skipped at the zipper root: the native ReadZipper escapes its + // own root there. + if tgt!(t, wz, *rz, z, z.at_root()) { + ("to_next_sibling_byte", SKIP_AT_ROOT.to_string()) + } else { + let r = tgt!(t, wz, *rz, z, z.to_next_sibling_byte()); + ("to_next_sibling_byte", show_byte_opt(r)) + } + } + 12 => { + let t = get!(d.modn(2)); + if tgt!(t, wz, *rz, z, z.at_root()) { + ("to_prev_sibling_byte", SKIP_AT_ROOT.to_string()) + } else { + let r = tgt!(t, wz, *rz, z, z.to_prev_sibling_byte()); + ("to_prev_sibling_byte", show_byte_opt(r)) + } + } + 13 => { + let t = get!(d.modn(2)); + let r = tgt!(t, wz, *rz, z, z.to_next_step()); + ("to_next_step", show_bool(r).to_string()) + } + 14 => { + // `ZipperIteration` is read-only: the target byte is still + // consumed, but the operation always applies to `rz`. + let _t = get!(d.modn(2)); + ("to_next_val", show_bool(rz.to_next_val()).to_string()) + } + 15 => { + let _t = get!(d.modn(2)); + let k = get!(d.modn(4)); + // k == 0 is specified as an unsuccessful descent. + ("descend_first_k_path", show_bool(rz.descend_first_k_path(k)).to_string()) + } + 16 => { + let _t = get!(d.modn(2)); + let k = get!(d.modn(4)); + // A whole k-path iteration: `to_next_k_path` on its own + // continues state left by `descend_first_k_path`. + let mut v: Vec = Vec::new(); + if rz.descend_first_k_path(k) { + v.push(hex_path(rz.path())); + while v.len() < 32 && rz.to_next_k_path(k) { + v.push(hex_path(rz.path())); + } + } + ("k_path_walk", v.join(",")) + } + 17 => { + let _t = get!(d.modn(2)); + ("descend_last_path", show_bool(rz.descend_last_path()).to_string()) + } + 18 => { + let t = get!(d.modn(2)); + let p = get!(d.path(6)); + let n = tgt!(t, wz, *rz, z, z.move_to_path(&p)); + ("move_to_path", format!("{n}")) + } + 19 => { + let t = get!(d.modn(2)); + let p = get!(d.path(6)); + let n = tgt!(t, wz, *rz, z, z.descend_to_existing(&p)); + ("descend_to_existing", format!("{n}")) + } + 20 => { + let t = get!(d.modn(2)); + let p = get!(d.path(6)); + let n = tgt!(t, wz, *rz, z, z.descend_to_val(&p)); + ("descend_to_val", format!("{n}")) + } + 21 => { + let t = get!(d.modn(2)); + let b = get!(d.path_byte()); + let r = tgt!(t, wz, *rz, z, z.descend_to_existing_byte(b)); + ("descend_to_existing_byte", show_bool(r).to_string()) + } + 22 => { + let t = get!(d.modn(2)); + let n = get!(d.modn(8)); + let r = tgt!(t, wz, *rz, z, z.descend_until_max_bytes(n)); + ("descend_until_max_bytes", show_bool(r).to_string()) + } + 23 => { + let t = get!(d.modn(2)); + let p = get!(d.path(6)); + let r = tgt!(t, wz, *rz, z, z.descend_to_check(&p)); + ("descend_to_check", show_bool(r).to_string()) + } + 24 => { + let t = get!(d.modn(2)); + let p = get!(d.path(6)); + let v = tgt!(t, wz, *rz, z, show_val(z.val_at(&p))); + ("val_at", v) + } + 25 => { + let t = get!(d.modn(2)); + let n = if t == 0 { + wz.make_map().val_count() + } else { + rz.make_map().val_count() + }; + ("make_map_val_count", format!("{n}")) + } + 26 => { + let t = get!(d.modn(2)); + let s = if t == 0 { + dump(&mut wz.fork_read_zipper()) + } else { + dump(&mut rz.fork_read_zipper()) + }; + ("dump", s) + } + 27 => { + let t = get!(d.modn(2)); + // The blind-zipper addition: `descend_until` reporting the bytes + // it descended. The observer's output is a blind zipper's only + // account of where it went, so it is compared byte for byte. + let mut obs: Vec = Vec::new(); + let r = tgt!(t, wz, *rz, z, z.descend_until_observed(&mut obs)); + ("descend_until_observed", format!("{}:{}", show_bool(r), hex_path(&obs))) + } + 28 => { + let t = get!(d.modn(2)); + let p = get!(d.path(6)); + // `get_val`/`get_val_at` must agree with `val`/`val_at`; they + // differ only in the lifetime of the reference returned. + let (g, ga, agree) = if t == 0 { + // A write zipper has no `ZipperReadOnlyValues`. + (wz.val().copied(), wz.val_at(&p).copied(), true) + } else { + let (g, ga) = (rz.get_val().copied(), rz.get_val_at(&p).copied()); + let agree = g == rz.val().copied() && ga == rz.val_at(&p).copied(); + (g, ga, agree) + }; + ( + "get_val_agrees", + format!("{}:{}:{}", show_val(g.as_ref()), show_val(ga.as_ref()), show_bool(agree)), + ) + } + 29 => { + let got = rz.to_next_get_val().copied(); + // `to_next_get_val` is specified as `to_next_val` followed by + // reading the value, so `Some` must mean it moved and must equal + // what `val` reports. + let agree = got == rz.val().copied() || (got.is_none() && rz.at_root()); + ( + "to_next_get_val", + format!("{}:{}:{}", show_bool(got.is_some()), show_val(got.as_ref()), show_bool(agree)), + ) + } + // ## Writing, on the write zipper + 30 => { + let v = get!(d.u8()) as u64; + ("set_val", show_val(wz.set_val(v).as_ref())) + } + 31 => ("remove_val", show_val(wz.remove_val(PRUNE).as_ref())), + 32 => { + // Must be `0`: a trie built from this subset has no dangling tip. + ("prune_path", format!("{}", wz.prune_path())) + } + 33 => ("prune_ascend", format!("{}", wz.prune_ascend())), + 34 => { + let leaky = focus_node_empty(&wz); + let r = wz.remove_branches(PRUNE); + // An empty node still comes back as `Some(..)` from + // `into_option()` for some representations, so `true` gets + // reported for a removal of nothing. Compared only when there + // was something below. + let s = if leaky { "?".to_string() } else { show_bool(r).to_string() }; + ("remove_branches", s) + } + 35 => { + let n = get!(d.modn(4)); + let m = get!(d.path_n(n)); + wz.remove_unmasked_branches(ByteMask::from_iter(m.iter().copied()), PRUNE); + ("remove_unmasked_branches", hex_path(&canon_mask(&m))) + } + 36 => { + wz.graft(&*rz); + ("graft", "-".to_string()) + } + 37 => { + let p = get!(d.path(6)); + wz.graft_src_at(&*rz, &p); + ("graft_src_at", hex_path(&p)) + } + 38 => ("join_into", show_status(wz.join_into(&*rz)).to_string()), + 39 => { + let leaky = focus_node_empty(&wz); + let st = wz.join_map_into(rz.make_map()); + let s = if leaky { "?".to_string() } else { show_status(st).to_string() }; + ("join_map_into", s) + } + 40 => ("meet_into", show_status(wz.meet_into(&*rz, PRUNE)).to_string()), + 41 => ("subtract_into", show_status(wz.subtract_into(&*rz, PRUNE)).to_string()), + 42 => { + let leaky = focus_node_empty(&wz); + let st = wz.restrict(&*rz); + let s = if leaky { "?".to_string() } else { show_status(st).to_string() }; + ("restrict", s) + } + 43 => { + // Skipped when either side has nothing below its focus: there + // `restricting` branches on whether an empty node happens to be + // materialised, and the branches differ in *effect*. + if focus_node_empty(&wz) || focus_node_empty(rz) { + ("restricting", SKIP_EMPTY_FOCUS.to_string()) + } else { + ("restricting", show_bool(wz.restricting(&*rz)).to_string()) + } + } + 44 => { + let k = get!(d.modn(4)); + let r = wz.join_k_path_into(k, PRUNE); + let s = if focus_node_empty(&wz) { "?".to_string() } else { show_bool(r).to_string() }; + ("join_k_path_into", s) + } + 45 => { + let p = get!(d.path(6)); + ("insert_prefix", show_bool(wz.insert_prefix(&p)).to_string()) + } + 46 => { + let n = get!(d.modn(6)); + ("remove_prefix", wz.remove_prefix(n).to_string()) + } + 47 => { + let leaky = focus_node_empty(&wz) && wz.val().is_none(); + let r = match wz.take_map(PRUNE) { + Some(m) => { + wz.graft_map(m); + "1" + } + None => "0", + }; + ("take_map_restore", if leaky { "?".to_string() } else { r.to_string() }) + } + 48 => { + let k = get!(d.modn(4)); + ("meet_k_path_into", show_bool(wz.meet_k_path_into(k, PRUNE)).to_string()) + } + 49 => { + let v = get!(d.u8()) as u64; + // Writing through the reference `get_val_mut` hands back. It + // must behave like `set_val` where a value exists and do nothing + // -- crucially, not create the path -- where one does not. + let old = match wz.get_val_mut() { + Some(slot) => { + let old = *slot; + *slot = v; + Some(old) + } + None => None, + }; + ("get_val_mut_write", show_val(old.as_ref())) + } + 50 => { + let v = get!(d.u8()) as u64; + let r = *wz.get_val_or_set_mut(v); + ("get_val_or_set_mut", show_val(Some(&r))) + } + 51 => { + let v = get!(d.u8()) as u64; + // `ran` records whether the closure was invoked; the contract is + // that it supplies the value only when none exists. + let mut ran = false; + let r = *wz.get_val_or_set_mut_with(|| { + ran = true; + v + }); + ("get_val_or_set_mut_with", format!("{}:{}", show_val(Some(&r)), show_bool(ran))) + } + 52 => { + let n = get!(d.modn(4)); + let m = get!(d.path_n(n)); + let ru = get!(d.boolean()); + wz.graft_masked_branches(&*rz, ByteMask::from_iter(m.iter().copied()), ru); + ("graft_masked_branches", format!("{}:{}", hex_path(&canon_mask(&m)), show_bool(ru))) + } + 53 => { + let p = get!(d.path(6)); + // `meet_2` takes two sources; the second is the first moved to `p`. + let mut b = rz.clone(); + b.descend_to(&p); + ("meet_2", show_status(wz.meet_2(&*rz, &b)).to_string()) + } + _ => ("nop", "-".to_string()), + }; + if check { + check_zipper(&wz, "write zipper", root0); + check_zipper(rz, "read zipper", root1); + } + let _ = writeln!( + out, + "{step} {name} ret={ret} W={} R={}", + fingerprint(&wz, root0), + fingerprint(rz, root1) + ); + step += 1; + } +} diff --git a/differential/src/repro.rs b/differential/src/repro.rs index 21cd8697..a13dd874 100644 --- a/differential/src/repro.rs +++ b/differential/src/repro.rs @@ -189,16 +189,14 @@ pub fn emit_repro(bytes: &[u8], upto: usize) -> String { 40 => "wz.restrict(&rz);".to_string(), 41 => "wz.restricting(&rz);".to_string(), 42 => { let k = g!(d.modn(4)); let pr = g!(d.boolean()); - if k == 0 { "// join_k_path_into(0): skipped by the harness".to_string() } - else { format!("wz.join_k_path_into({k}, {pr});") } } + format!("wz.join_k_path_into({k}, {pr});") } 43 => { let p = g!(d.path(6)); - if p.is_empty() { "// insert_prefix(\"\"): skipped by the harness".to_string() } - else { format!("wz.insert_prefix({});", rs_bytes(&p)) } } + format!("wz.insert_prefix({});", rs_bytes(&p)) } 44 => { let n = g!(d.modn(6)); format!("wz.remove_prefix({n});") } 45 => { let pr = g!(d.boolean()); format!("if let Some(m) = wz.take_map({pr}) {{ wz.graft_map(m); }}") } 46 => { let k = g!(d.modn(4)); let pr = g!(d.boolean()); - format!("if {k} != 0 && wz.child_count() != 0 {{ wz.meet_k_path_into({k}, {pr}); }}") } + format!("wz.meet_k_path_into({k}, {pr});") } 47 => { let t = g!(d.modn(2)); format!("{{ let mut obs = Vec::new(); {}.descend_until_observed(&mut obs); }}", z!(t)) } 48 => { let v = g!(d.u8()) as u64; diff --git a/lean/PRUNED_FINDINGS.md b/lean/PRUNED_FINDINGS.md new file mode 100644 index 00000000..106925de --- /dev/null +++ b/lean/PRUNED_FINDINGS.md @@ -0,0 +1,201 @@ +# Findings from the dangling-path-free model + +What `lean/pruned_differential.py` found, driving `PrunedModel` (the oracle) +against `differential/src/pruned.rs` (the crate) on `pathmap` 0.4.0 at +`833d524`. + +This is a separate file from `FINDINGS.md` because it is a separate claim. +`FINDINGS.md` records what the crate does with dangling paths, as discovered by +a model that reproduces them. This model instead *forbids* them: its subset is +chosen so that no operation in it should be able to make a location that leads +nowhere. So every finding here has the same shape — "this operation made one" — +and the interest is in which operations, and why. + +Minimal reproducers are in `lean/pruned-corpus/`, 9–47 bytes each. Replay one +with + + ./target/release/pruned_trace lean/pruned-corpus/.bin + ./lean/.lake/build/bin/pruned-oracle lean/pruned-corpus/.bin + +or check the whole corpus with `./lean/pruned_differential.py +lean/pruned-corpus/*`. + +## 1. An empty write materialises the focus + +**Seven operations create or keep a dangling path when what they write is +empty.** First 300 random inputs: 63 of 70 divergences, and every one of them +this. + +| operation | reproducer | +| --- | --- | +| `graft` | `graft-empty-src-creates-dangling-focus.bin` | +| `graft_src_at` | `graft_src_at-empty-src-creates-dangling-focus.bin` | +| `graft_masked_branches` | `graft_masked_branches-creates-dangling-focus.bin` | +| `meet_2` | `meet_2-empty-result-creates-dangling-focus.bin` | +| `restrict` | `restrict-empty-result-creates-dangling-focus.bin` | +| `restricting` | `restricting-creates-dangling-focus.bin` | +| `remove_prefix` | `remove_prefix-creates-dangling-chain.bin` | + +The smallest is nine bytes. An empty `map1`, a `map0` holding one root value, a +write zipper at the map root descended one byte to a location that does not +exist, and then `graft` from a read zipper whose subtrie is empty: + + 0 descend_to_byte ret=00 W=00 o00 e0 v- c0 n0 + 1 graft ret=- W=00 o00 e0 v- c0 n0 model + 1 graft ret=- W=00 o00 e1 v- c0 n0 crate + MAP0 _:- model + MAP0 _:-,00:- crate + +`path_exists()` reports `true` at a location with no value and no children. +Nothing leads there and nothing can reach it except a zipper that already knows +the path, so it is pure overhead to every traversal — and `val_count() == 0` +beside `child_count() == 0` and `path_exists() == true` is a state no reader of +the trait documentation would expect to have to handle. + +It is worth being precise about what this is, because "forgot to prune" is only +half of it. There are two cases, and the second is the one that matters: + +* Where the focus **existed**, the operation empties it and leaves the chain + behind. That is a missing prune. +* Where the focus **did not exist**, the operation *creates* it — the write path + materialises the node chain down to the focus before discovering it has + nothing to put there, and then returns without undoing that. The seven + reproducers above are all of this kind, because the shrinker found it the + cheaper shape to reach. `graft` with an empty source is accidentally + `create_path`. + +`remove_prefix` shows the scale: it creates the whole chain, not just the tip. + + 2 remove_prefix ret=1 MAP0 _:- model + 2 remove_prefix ret=1 MAP0 _:-,00:-,0000:-,000000:- crate + +**Why these seven and not the others.** `remove_val`, `remove_branches`, +`remove_unmasked_branches`, `meet_into`, `subtract_into` and `join_k_path_into` +take a `prune: bool`, and with `prune = true` — which is what this harness +passes throughout — they clean up correctly. The seven above have no such +parameter, so a caller who wants a tidy trie has no way to ask for one. The +asymmetry looks unintended rather than designed: `meet_into` and `meet_2` are +the same operation with and without a destination, and only one of them can be +told to prune. + +Two fixes are available and they are not equivalent. Adding `prune` to the +seven makes the behaviour reachable; making the empty write a no-op on a +non-existent focus makes it correct, since an operation whose result is "nothing" +has no business creating a location. The second also fixes the `create_path` +accident, which the first does not. + +## 2. `graft_masked_branches` creates a child for a branch the source lacks + +`graft_masked_branches-creates-dangling-child.bin`, 10 bytes. Both maps empty, +write zipper at the root, mask `{0x01}`, `remove_unset = false`: + + 0 graft_masked_branches ret=01:0 W=_ o_ e1 v- c0 n0 model + 0 graft_masked_branches ret=01:0 W=_ o_ e1 v- c1 n0 crate + MAP0 _:- model + MAP0 _:-,01:- crate + +This is finding 1's mechanism one level down, and it is worse there, because the +location it creates is a *child of the focus* rather than the focus itself: the +focus's `child_mask` now has a bit set for a branch that holds nothing, and +`child_count() == 1` with `val_count() == 0`. Every consumer that uses +`child_mask` to decide where to recurse will now walk into it. + +Each set bit of the mask is specified as a `graft_src_at` of the source's +corresponding child, and grafting nothing removes — so a set bit whose branch is +absent from the source must leave that branch absent here. Instead it is +created. + +## 3. Pre-existing classes this model also reports + +Two divergence shapes are not about dangling paths. Both are already recorded +against the other model; they appear here because the operation subsets overlap, +and they are in the corpus so a regression in either shows up in whichever +harness is run. + +* **A value collision resolves to the counterpart.** + `join_into-value-bias-by-node-layout.bin`. `u64`'s `pjoin` returns + `Identity(SELF_IDENT)`, so the destination's value must survive a collision; + at one location out of six the crate kept the source's (`0301:118` against + `0301:0`). Which location depends on node layout, not on the paths — see + `FINDINGS.md` on value bias. 7 of 4000 inputs. + +* **`Identity` is not reported where nothing changed.** + `join_map_into-status-element-when-unchanged.bin`. The source map is + `{[] ↦ v}` and the destination focus already holds `v`, so both the value step + and the node step are identities and the status must be `Identity`; the crate + says `Element`. `FINDINGS.md` #8. 87 of 4000 inputs, across `join_map_into` + (most), `subtract_into` and `meet_into`. + +## 4. Against `fuzz-fixes-v3` + +Same 4000 inputs, same seed, with the harness built on `fuzz-fixes-v3` +(`ee7546e`) and the oracle unchanged. `fuzz-fixes-v3` carries 73 commits of +fixes off an older master, several of them about dangling paths, so the question +is which of the above it already answers. + +| finding | master `ec818cf` | `fuzz-fixes-v3` | +| --- | --- | --- | +| #1 + #2, empty write materialises a location | 897 + 64 | **not fixed** — 974, and all 8 reproducers still diverge | +| #3, value bias | 7 | fixed (`3dae731`, "Make meet/join value bias independent of node layout") | +| #3, `Identity` not reported | 87 | fixed | + +So the branch fixes the one class this model genuinely inherited, and neither of +the two it found. That is not surprising — `fuzz-fixes-v3` was driven by the +other model, which *reproduces* dangling paths rather than forbidding them, so no +amount of fuzzing against it could have reported finding 1. It is the clearest +argument for keeping both models: they cannot find each other's bugs. + +Two attribution traps are worth writing down, because both caught me. + +* The `Identity` row needs a qualification. Most of that class was **the models + describing a `join_map_into` status master had already changed** in PR #142 + (`276fca0`, issue #139): its empty-source-node exit used to `return` the node + status on its own, discarding a value status for a value it had already + written, and master replaced that with + `node_status.merge(val_status, true, true)`. Both models still described the + early return — corrected in the commit after this one, which takes the class + from 104 of 4000 to 8. `fuzz-fixes-v3` predates PR #142, so it scored 0 on this + not by fixing anything but by still matching what the models said. +* `3e839e8` ("Fix join_into replacing or misreporting a destination that holds + the source") looks like a candidate and is **already on master** as `1e3b1c3` + (PR #116); cherry-picking it yields only comment churn and duplicate tests. + +Check `git log master -S` before attributing anything here to v3. + +Two things in the v3 column are **not** findings and should not be read as any: + +* **420 inputs diverge in `descend_first_k_path` / `k_path_walk`.** v3 changes + the k-path walk (`7f9c59a`, "Fix the default k-path walk looping forever at a + leaf", among others) and updates its own copy of the model to match. + `PrunedModel` was ported from master's model, so it still specifies master's + behaviour. This is spec drift between the two branches, and re-measuring the + k-path operations on v3 needs the port redone against v3's model. +* **45 of 600 inputs show `subtract_into` reporting `Identity`** where the model + says `Element` — the opposite direction from finding 3. v3 deliberately + changed the integer instance (`f8a4599`, "Return Identity from the integer + psubtract when nothing was subtracted"); `Basic.u64Ops` is master's and + returns `Element(*self)`. Also spec drift. + +Both are visible only because the oracle is pinned to master while the crate is +not. The `STATUS-ONLY` shape in particular is two-directional, so the driver's +`KNOWN` note for it says to read the direction rather than the tag. + +## What is not covered + +The subset deliberately excludes three things, and a reader comparing the two +harnesses should know they are gaps here rather than absences of defects: + +* `create_path`, and `remove_val(false)` — they make dangling paths on purpose. +* A write zipper rooted below the map root. It holds a node at its own root, + which survives as a dangling path once everything below it is removed, and + `prune_path` is documented not to rise above the zipper's origin. So a + dangling root there is the documented behaviour, not a defect, and comparing + it would drown everything else. Off-root *writing* is covered: the + root-rooted zipper reaches every focus with `descend_to`. +* `graft_child_maps`, which `FINDINGS.md` #15 records as broken three ways. + +Operations the subset *does* cover are specified, not skipped, even where they +are known to leak — which is why finding 1 is reported rather than suppressed. +The two `skip:` reasons that remain (`at-root`, `empty-focus`) are the ones where the crate's behaviour is a function of node +materialisation rather than of trie state, so there is nothing for a model to +agree with; each is commented at its site in `PrunedModel/Fuzz.lean`. diff --git a/lean/PathMapModel/Basic.lean b/lean/PathMapModel/Basic.lean index ff22667f..0faec241 100644 --- a/lean/PathMapModel/Basic.lean +++ b/lean/PathMapModel/Basic.lean @@ -71,6 +71,22 @@ def u64Ops : ValOps UInt64 where psub a b := if a == b then .none else .elem a beq a b := a == b +/-- The instance `pathmap` provides for `()` (see `impl Lattice for ()` in `src/ring.rs`). + +Both `pjoin` and `pmeet` return `Identity(SELF_IDENT | COUNTER_IDENT)` — with only +one value there is nothing to choose between, so each operand is equally "the +answer", and the node algebra is told so. `psubtract` of two `()`s annihilates, +which `src/ring.rs`'s own `option_subtract_test` asserts. + +This is the instance under which a trie is exactly a *set of paths*, and it is +the one for which the lattice laws hold in full — including commutativity, which +`u64Ops` does not satisfy. See `PrunedModel/Lattice.lean`. -/ +def unitOps : ValOps Unit where + pjoin _ _ := .identity true true + pmeet _ _ := .identity true true + psub _ _ := .none + beq _ _ := true + /-! ## Prefix order -/ /-- `p ≼ q`: `p` is a prefix of `q`. -/ @@ -120,6 +136,79 @@ def Path.le (p q : Path) : Bool := Path.lt p q || p == q instance : LT Path := ⟨fun p q => Path.lt p q = true⟩ instance : LE Path := ⟨fun p q => Path.le p q = true⟩ +/-! ### `Path.lt` is a strict total order + +Needed to show that the canonical form is *unique* — that two sorted, +duplicate-free entry lists holding the same values are the same list — which is +what lets `PrunedModel/Lattice.lean` state the lattice laws as equations rather +than as "equal at every path". Nothing else in the model needs them, which is +why they were not here before. -/ + +/-- `UInt8` order facts, routed through `toNat` so `omega` can see them. -/ +private theorem u8_lt_trans {a b c : UInt8} (h1 : a < b) (h2 : b < c) : a < c := by + rw [UInt8.lt_iff_toNat_lt] at *; omega +private theorem u8_lt_irrefl (a : UInt8) : ¬ (a < a) := by + rw [UInt8.lt_iff_toNat_lt]; omega +private theorem u8_eq_of_not_lt {a b : UInt8} (h1 : ¬ (a < b)) (h2 : ¬ (b < a)) : a = b := by + rw [UInt8.lt_iff_toNat_lt] at h1 h2 + exact UInt8.toNat_inj.mp (by omega) +private theorem u8_lt_of_lt_of_not_gt {a b c : UInt8} (h1 : a < b) (h2 : ¬ (c < b)) : a < c := by + rw [UInt8.lt_iff_toNat_lt] at *; omega + +theorem Path.lt_cons (a b : UInt8) (as bs : Path) : + Path.lt (a :: as) (b :: bs) + = if a < b then true else if b < a then false else Path.lt as bs := rfl + +@[simp] theorem Path.lt_irrefl : ∀ p : Path, Path.lt p p = false + | [] => rfl + | a :: as => by simp [Path.lt_cons, u8_lt_irrefl a, Path.lt_irrefl as] + +theorem Path.lt_trans : ∀ {p q r : Path}, + Path.lt p q = true → Path.lt q r = true → Path.lt p r = true + | [], [], _, h1, _ => by simp [Path.lt] at h1 + | [], _ :: _, [], _, h2 => by simp [Path.lt] at h2 + | [], _ :: _, _ :: _, _, _ => rfl + | _ :: _, [], _, h1, _ => by simp [Path.lt] at h1 + | _ :: _, _ :: _, [], _, h2 => by simp [Path.lt] at h2 + | a :: as, b :: bs, c :: cs, h1, h2 => by + rw [Path.lt_cons] at h1 h2 ⊢ + by_cases hab : a < b + · by_cases hcb : c < b + · -- the hypothesis forces `b < c`, which `c < b` contradicts + simp [hcb] at h2 + exact absurd (u8_lt_trans h2 hcb) (u8_lt_irrefl b) + · simp [u8_lt_of_lt_of_not_gt hab hcb] + · by_cases hba : b < a + · simp [hab, hba] at h1 + · -- a = b, so the comparison is decided one level down + have hab' : a = b := u8_eq_of_not_lt hab hba + subst hab' + simp only [hab] at h1 + by_cases hac : a < c + · simp [hac] + · by_cases hca : c < a + · simp [hca] at h2 + exact absurd (u8_lt_trans h2 hca) (u8_lt_irrefl a) + · simp only [hac, hca] at h2 ⊢ + exact Path.lt_trans h1 h2 + +theorem Path.lt_total : ∀ (p q : Path), Path.lt p q = true ∨ p = q ∨ Path.lt q p = true + | [], [] => Or.inr (Or.inl rfl) + | [], _ :: _ => Or.inl rfl + | _ :: _, [] => Or.inr (Or.inr rfl) + | a :: as, b :: bs => by + rw [Path.lt_cons, Path.lt_cons] + by_cases hab : a < b + · exact Or.inl (by simp [hab]) + · by_cases hba : b < a + · exact Or.inr (Or.inr (by simp [hba])) + · have : a = b := u8_eq_of_not_lt hab hba + subst this + rcases Path.lt_total as bs with h | h | h + · exact Or.inl (by simp [hab, h]) + · exact Or.inr (Or.inl (by simp [h])) + · exact Or.inr (Or.inr (by simp [hab, h])) + /-- Insertion into a `Path.lt`-sorted list, dropping duplicates. -/ def Path.insertSorted (p : Path) : List Path → List Path | [] => [p] diff --git a/lean/PathMapModel/Fuzz.lean b/lean/PathMapModel/Fuzz.lean index 3bc69951..6e0e199a 100644 --- a/lean/PathMapModel/Fuzz.lean +++ b/lean/PathMapModel/Fuzz.lean @@ -67,19 +67,15 @@ agree exactly or every input with a skip diverges. the trait the op needs. * `skip:at-root` — `to_next`/`to_prev_sibling_byte` at the zipper root, where the native read zipper escapes its own root. -* `skip:k0` — a degenerate `k = 0` on `join`/`meet_k_path_into`. * `skip:empty-focus` — the focus has nothing below it, where the op's behaviour is a function of node materialisation rather than trie state. -* `skip:empty-path` — `insert_prefix("")`, which destroys the subtrie. * `skip:quarantined` — the op is disabled outright (op 54). Each is recorded in FINDINGS.md and commented at its site. -/ def skipAct : String := "skip:act" def skipAtRoot : String := "skip:at-root" -def skipK0 : String := "skip:k0" def skipEmptyFocus : String := "skip:empty-focus" -def skipEmptyPath : String := "skip:empty-path" def skipQuarantined : String := "skip:quarantined" /-! ## Rendering -/ @@ -416,26 +412,17 @@ def step (s : St) (d : Dec) : Option (St × Dec) := do let (r, z) := s.wz.restricting s.rz some (emit { s with wz := z } "restricting" (showBool r), d) | 42 => do let (k, d) ← d.mod 4; let (pr, d) ← d.bool - -- `join_k_path_into(0)` should be the identity but destroys the - -- subtrie in pathmap 0.3.1; see `Zip.joinKPathInto`. - if k == 0 then some (emit s "join_k_path_into" skipK0, d) - else - -- The bool is another `AbstractNodeRef` leak: an empty node still - -- comes back as `Some(...)` from `into_option()` for some - -- representations, so `true` gets reported for a collapse that - -- produced nothing. Compared only when something survived. - -- See FINDINGS.md #8. - let (r, z) := s.wz.joinKPathInto ops k pr - some (emit { s with wz := z } "join_k_path_into" - (if z.focusNodeIsEmpty then "?" else showBool r), d) + -- The bool is another `AbstractNodeRef` leak: an empty node still + -- comes back as `Some(...)` from `into_option()` for some + -- representations, so `true` gets reported for a collapse that + -- produced nothing. Compared only when something survived. + -- See FINDINGS.md #8. + let (r, z) := s.wz.joinKPathInto ops k pr + some (emit { s with wz := z } "join_k_path_into" + (if z.focusNodeIsEmpty then "?" else showBool r), d) | 43 => do let (p, d) ← d.path - -- `insert_prefix("")` destroys the subtrie in pathmap 0.3.1; see - -- `Zip.insertPrefix`. Skipped so the known bug does not mask others. - if p.isEmpty then - some (emit s "insert_prefix" skipEmptyPath, d) - else - let (r, z) := s.wz.insertPrefix p - some (emit { s with wz := z } "insert_prefix" (showBool r), d) + let (r, z) := s.wz.insertPrefix p + some (emit { s with wz := z } "insert_prefix" (showBool r), d) | 44 => do let (n, d) ← d.mod 6 let (r, z) := s.wz.removePrefix n some (emit { s with wz := z } "remove_prefix" (toString r), d) @@ -450,15 +437,8 @@ def step (s : St) (d : Dec) : Option (St × Dec) := do | some mm => some (emit { s with wz := z.graftMap mm } "take_map_restore" "1", d) | none => some (emit { s with wz := z } "take_map_restore" "0", d) | 46 => do let (k, d) ← d.mod 4; let (pr, d) ← d.bool - -- `meet_k_path_into` is not implementable for these arguments; see - -- `Zip.meetKPathUnspecified`, whose two disjuncts are split out here - -- so the skip names which one fired. The Rust side matches. - if k == 0 then some (emit s "meet_k_path_into" skipK0, d) - else if s.wz.focusNodeIsEmpty then - some (emit s "meet_k_path_into" skipEmptyFocus, d) - else - let (r, z) := s.wz.meetKPathInto ops k pr - some (emit { s with wz := z } "meet_k_path_into" (showBool r), d) + let (r, z) := s.wz.meetKPathInto ops k pr + some (emit { s with wz := z } "meet_k_path_into" (showBool r), d) | 47 => do let (t, d) ← d.mod 2 -- The blind-zipper addition: `descend_until` reporting the bytes it -- descended. The observer's output is a blind zipper's only account diff --git a/lean/PathMapModel/Spec.lean b/lean/PathMapModel/Spec.lean index 389a73ae..b0eab2a8 100644 --- a/lean/PathMapModel/Spec.lean +++ b/lean/PathMapModel/Spec.lean @@ -140,10 +140,7 @@ theorem isPrefixOf_append (p q : Path) : p ≼ (p ++ q) := by | nil => simp [isPrefixOf] | cons a as ih => simp [isPrefixOf, ih] -@[simp] theorem lt_irrefl (p : Path) : Path.lt p p = false := by - induction p with - | nil => simp [Path.lt] - | cons a as ih => simp [Path.lt, ih] +-- `Path.lt_irrefl` now lives in Basic.lean, beside `lt_trans` and `lt_total`. end Path diff --git a/lean/PathMapModel/Write.lean b/lean/PathMapModel/Write.lean index 4ae6d03b..e394ac38 100644 --- a/lean/PathMapModel/Write.lean +++ b/lean/PathMapModel/Write.lean @@ -268,7 +268,9 @@ It also short-circuits: when the map has no root node, the node status is returned directly and the value status computed above is discarded — even though the value has already been written. -/ def joinMapInto (m : PathMap V) : AlgStatus × Zip V := - let (valStatus, valWasNone, z1) := + -- `merge` is called with both "was none" flags set, as the crate does, so the + -- second component is carried only for symmetry with the other operations. + let (valStatus, _valWasNone, z1) := match z.val, m.valAt [] with | some sv, some mv => let r := ops.pjoin sv mv @@ -281,19 +283,26 @@ def joinMapInto (m : PathMap V) : AlgStatus × Zip V := | none, none => (AlgStatus.none, true, z) let srcB := (m.removeVal []).2 if srcB.isEmptyMap then - -- Short-circuit, and note the asymmetry with `join_into`: this branch tests + -- Note the asymmetry with `join_into`: this branch tests -- `self.get_focus().is_none()` (does a node exist at all?), not -- `node_is_empty()`. So a *bare* focus reports `Identity` here, where -- `join_into` on the same state reports `None`. - (match z1.entry with - | .bare | .valued _ => AlgStatus.identity - | .absent => AlgStatus.none, z1) + -- + -- The node status is *merged* with the value status rather than returned on + -- its own. It used to be returned directly -- an early `return` that + -- discarded a value the operation had already written -- which is + -- issue #139, fixed by PR #142 (`276fca0`). Both exits of the crate's + -- `join_map_into` now end in the same `merge`. + (AlgStatus.merge + (match z1.entry with + | .bare | .valued _ => AlgStatus.identity + | .absent => AlgStatus.none) valStatus true true, z1) else let selfB := z1.focusNode let r := PathMap.join ops selfB srcB let nodeStatus := if PathMap.beqT ops r selfB then AlgStatus.identity else AlgStatus.element let z2 := if nodeStatus == .identity then z1 else z1.withTrie (z1.trie.graftBelow z1.focus r) - (AlgStatus.merge nodeStatus valStatus true valWasNone, z2) + (AlgStatus.merge nodeStatus valStatus true true, z2) /-- `ZipperWriting::join_into_take`: like `join_into`, but the source subtrie is removed from the source zipper's trie. Returns the updated destination *and* @@ -437,18 +446,13 @@ def joinKPathInto (k : Nat) (prune : Bool) : Bool × Zip V := let res := !r.isEmptyMap (res, if prune && !res then (z1.prunePath).2 else z1) -/-- `meet_k_path_into` is **not implementable** for these arguments: its -provisional implementation drives `descend_first_k_path` through the -`ZipperIteration` *default* loop, which spins forever when the focus has no -children, and which escapes the focus's subtree entirely when `k = 0`. -Verified against `pathmap` 0.3.1: `meet_k_path_into(1, false)` on a leaf hangs. -/ -def meetKPathUnspecified (k : Nat) : Bool := k == 0 || z.childCount == 0 - /-- `ZipperWriting::meet_k_path_into`: strip the leading `k` bytes from every path below the focus and meet the results. -Values at depth exactly `k` become the focus value. Only meaningful when -`meetKPathUnspecified` is `false`. -/ +Values at depth exactly `k` become the focus value. The meet replaces the whole +subtrie, focus value included, so an empty meet leaves no focus value and no +branches (`remove_subtrie`). With `k = 0` the only subtrie is the focus's own, +so it is the identity; a focus with no children meets nothing and is emptied. -/ def meetKPathInto (k : Nat) (prune : Bool) : Bool × Zip V := let kps := (z.trie.subtrie z.focus).kPaths k let result : Option (PathMap V) := @@ -459,8 +463,8 @@ def meetKPathInto (k : Nat) (prune : Bool) : Bool × Zip V := | some a => some (PathMap.meet ops a m)) none let (b, z') := match result with - | some m => if m.isEmptyMap then (false, (z.removeBranches false).2) else (true, z.graftMap m) - | none => (false, (z.removeBranches false).2) + | some m => if m.isEmptyMap then (false, (z.removeSubtrie false).2) else (true, z.graftMap m) + | none => (false, (z.removeSubtrie false).2) (b, if prune then (z'.prunePath).2 else z') end Zip diff --git a/lean/PrunedMain.lean b/lean/PrunedMain.lean new file mode 100644 index 00000000..3018be81 --- /dev/null +++ b/lean/PrunedMain.lean @@ -0,0 +1,91 @@ +import PrunedModel + +/-! +The oracle for the dangling-path-free model. + +One-shot: + + pruned-oracle -- decode and run the file's bytes + pruned-oracle -- read the bytes from stdin + +Resident: + + pruned-oracle --server -- one process, many inputs + +Spawning a fresh process per fuzzer input costs more than running the input +does, so `pruned_differential.py` keeps the oracle resident and feeds it work +over stdin. The protocol matches `differential/src/server.rs`, one command per +line: + + run-input run the decoded bytes, print the trace + quit exit 0 + +The reply is the trace lines, then exactly one terminator line, which is the +only line beginning with `!`: + + !DONE the trace above is complete + !TIMEOUT exceeded + !PANIC malformed command + +`differential/src/bin/pruned_trace.rs` prints the same trace from the real +crate for the same input bytes; `lean/pruned_differential.py` diffs them. + +The timeout argument is parsed and ignored, as in `lean/Main.lean`: no +in-process timeout is reachable from Lean's `IO.asTask`/`IO.hasFinished`, and +the driver has to enforce the deadline from outside regardless, since no +in-process timeout can save a child that has died. The model is total, so it +cannot hang, only be slow. +-/ + +open PrunedModel + +/-- Decode a lowercase/uppercase hex string. -/ +def hexDecode (s : String) : Option ByteArray := + let cs := s.toList + if cs.length % 2 != 0 then none + else + let rec go : List Char → ByteArray → Option ByteArray + | [], acc => some acc + | a :: b :: rest, acc => do + let hi ← a.toString.toNat? |>.orElse fun _ => + "0123456789abcdef".toList.idxOf? a.toLower + let lo ← b.toString.toNat? |>.orElse fun _ => + "0123456789abcdef".toList.idxOf? b.toLower + go rest (acc.push (UInt8.ofNat (hi * 16 + lo))) + | _, _ => none + go cs ByteArray.empty + +/-- The resident command loop. -/ +partial def serve : IO Unit := do + let stdin ← IO.getStdin + let stdout ← IO.getStdout + let rec loop : IO Unit := do + let line ← stdin.getLine + -- `getLine` returns "" only at EOF; a blank line is "\n". + if line.isEmpty then return + let line := line.trimAscii.toString + if line == "quit" then return + let terminator ← + match line.splitOn " " with + | "run-input" :: ms :: rest => + match ms.toNat?, hexDecode (String.intercalate " " rest) with + | some _, some bytes => do + for line in Fuzz.run bytes 256 do + stdout.putStrLn line + pure "!DONE" + | _, _ => pure "!PANIC bad run-input arguments" + | _ => pure s!"!PANIC unknown command: {line}" + stdout.putStrLn terminator + stdout.flush + loop + loop + +def main (args : List String) : IO Unit := do + if args.contains "--server" then + return ← serve + let files := args.filter (fun a => !a.startsWith "--") + let bytes ← match files with + | [] => (← IO.getStdin).readBinToEnd + | path :: _ => IO.FS.readBinFile path + for line in Fuzz.run bytes 256 do + IO.println line diff --git a/lean/PrunedModel.lean b/lean/PrunedModel.lean new file mode 100644 index 00000000..c7fc1de9 --- /dev/null +++ b/lean/PrunedModel.lean @@ -0,0 +1,12 @@ +import PrunedModel.Canon +import PrunedModel.Map +import PrunedModel.Zipper +import PrunedModel.Write +import PrunedModel.Spec +import PrunedModel.Lattice +import PrunedModel.Nested +import PrunedModel.Pointwise +import PrunedModel.Refine +import PrunedModel.Zippy +import PrunedModel.Project +import PrunedModel.Fuzz diff --git a/lean/PrunedModel/Canon.lean b/lean/PrunedModel/Canon.lean new file mode 100644 index 00000000..8a42e8f3 --- /dev/null +++ b/lean/PrunedModel/Canon.lean @@ -0,0 +1,453 @@ +import PathMapModel.Basic + +/-! +# Canonical association lists + +`PrunedMap` carries its canonical form in its *type*: an entry list sorted +strictly by key, so there is no junk inhabitant to exclude afterwards. This file +is the list-level development that makes that possible — everything needed to +build the proof field and to read it back off, with no mention of `PrunedMap`. + +Two predicates, and the first implies the second: + +* `SortedKeys` — keys strictly increasing in `Path.lt`. This is the invariant. +* `DistinctKeys` — no key bound twice. Implied, because `Path.lt` is + irreflexive; `distinctKeys_of_sortedKeys` is the proof. + +The payoff is `eq_of_sortedKeys_of_lookup`: a sorted list is determined by its +lookup function. That is what makes `PrunedMap` equality *observational*, and +hence what lets `PrunedModel/Lattice.lean` state the lattice laws as equations +with no side conditions at all. + +These proofs were the first and last thirds of `Lattice.lean`, behind a +`Canonical` predicate every law had to carry as a hypothesis. Moving the +invariant into the type removed the hypothesis; the proofs are unchanged. +-/ + +namespace PrunedModel + +open PathMapModel + +variable {V : Type} + +/-! ## Paths and lookup -/ + +/-- Every path is a prefix of itself. -/ +theorem isPrefixOf_self : ∀ p : Path, (p ≼ p) = true + | [] => rfl + | _ :: as => by simp [Path.isPrefixOf, isPrefixOf_self as] + +/-- A key is bound: `lookup` finds whatever `map (·.1)` saw. -/ +theorem lookup_isSome_of_mem_keys {l : List (Path × V)} {p : Path} + (h : p ∈ l.map (·.1)) : (l.lookup p).isSome = true := by + obtain ⟨kv, hmem, heq⟩ := List.mem_map.mp h + exact List.lookup_isSome_iff.mpr ⟨kv, hmem, by simp [heq]⟩ + +/-- …and conversely, `lookup` only succeeds on a key. -/ +theorem mem_keys_of_lookup_isSome {l : List (Path × V)} {p : Path} + (h : (l.lookup p).isSome = true) : p ∈ l.map (·.1) := by + obtain ⟨kv, hmem, hb⟩ := List.lookup_isSome_iff.mp h + exact List.mem_map.mpr ⟨kv, hmem, (eq_of_beq hb).symm⟩ + +/-- An unbound key looks up to `none` — the contrapositive of +`mem_keys_of_lookup_isSome`. -/ +theorem lookup_eq_none_of_not_mem_keys {l : List (Path × V)} {k : Path} + (h : k ∉ l.map (·.1)) : l.lookup k = none := by + cases hl : l.lookup k with + | none => rfl + | some v => + exact absurd (mem_keys_of_lookup_isSome (l := l) (p := k) (by rw [hl]; rfl)) h + +/-! ## Canonicalisation -/ + +/-- Deduplicate an association list, keeping the *first* binding for each key. +Left-biased, matching `pathmap`'s `Identity(SELF_IDENT)` value instances. -/ +def dedupVals (l : List (Path × V)) : List (Path × V) := + l.foldl (fun acc kv => if acc.any (fun x => x.1 == kv.1) then acc else acc ++ [kv]) [] + +/-- Insert into a key-sorted association list (assumes the key is not present). -/ +def insertValSorted (kv : Path × V) : List (Path × V) → List (Path × V) + | [] => [kv] + | kv' :: rest => + if Path.lt kv.1 kv'.1 then kv :: kv' :: rest + else kv' :: insertValSorted kv rest + +/-- Canonicalise a raw association list: keep the first binding per key, sort by key. -/ +def normVals (l : List (Path × V)) : List (Path × V) := + (dedupVals l).foldl (fun acc kv => insertValSorted kv acc) [] + +/-! ## Canonicalisation moves no lookup -/ + +/-- `dedupVals` keeps the first binding for each key, so it moves no lookup. +Stated with an accumulator, which is what lets the `foldl` be inducted on. -/ +private theorem lookup_dedupAux (k : Path) : + ∀ (l acc : List (Path × V)), + (l.foldl (fun acc kv => if acc.any (fun x => x.1 == kv.1) then acc else acc ++ [kv]) acc).lookup k + = (acc.lookup k).or (l.lookup k) + | [], acc => by simp + | (key, val) :: rest, acc => by + rw [List.foldl_cons, lookup_dedupAux k rest] + cases hany : acc.any (fun x => x.1 == key) with + | true => + -- `key` is already bound, so the entry is dropped and `acc` answers for it. + simp only [if_pos, List.lookup_cons] + cases hk : k == key with + | false => simp + | true => + -- `acc.lookup k` is `some`, so it absorbs whatever comes after. + obtain ⟨p, hp, hpk⟩ := List.any_eq_true.mp hany + have hsome : (acc.lookup k).isSome = true := by + refine List.lookup_isSome_iff.mpr ⟨p, hp, ?_⟩ + have h1 : k = key := by simpa using hk + have h2 : p.1 = key := by simpa using hpk + simp [h1, h2] + cases hs : acc.lookup k with + | none => simp [hs] at hsome + | some v => simp + | false => + -- `key` is new, so the entry is appended and `lookup` sees it after `acc`. + simp only [if_neg, Bool.false_eq_true, not_false_eq_true] + cases hk : k == key <;> + simp [List.lookup_append, List.lookup_cons, hk] + +/-- `dedupVals` preserves every lookup. -/ +theorem lookup_dedupVals (l : List (Path × V)) (k : Path) : + (dedupVals l).lookup k = l.lookup k := by + rw [dedupVals] + simpa using lookup_dedupAux k l [] + +/-- Which keys `insertValSorted` leaves behind: the inserted one, and the old ones. -/ +theorem mem_keys_insertValSorted (kv : Path × V) : + ∀ (acc : List (Path × V)) (k : Path), + k ∈ (insertValSorted kv acc).map (·.1) ↔ (k = kv.1 ∨ k ∈ acc.map (·.1)) + | [], k => by simp [insertValSorted] + | kv' :: rest, k => by + rw [insertValSorted] + cases h : Path.lt kv.1 kv'.1 with + | true => simp + | false => + simp only [Bool.false_eq_true, if_false, List.map_cons, List.mem_cons, + mem_keys_insertValSorted kv rest k] + constructor + · intro hm + rcases hm with hm | hm | hm + · exact Or.inr (Or.inl hm) + · exact Or.inl hm + · exact Or.inr (Or.inr hm) + · intro hm + rcases hm with hm | hm | hm + · exact Or.inr (Or.inl hm) + · exact Or.inl hm + · exact Or.inr (Or.inr hm) + +/-- `insertValSorted` is a lookup update, as long as the key is not already +bound. That hypothesis is what rules out shadowing an existing binding, and it +is exactly what `dedupVals` establishes before the sort runs. -/ +theorem lookup_insertValSorted : + ∀ (kv : Path × V) (acc : List (Path × V)) (k : Path), kv.1 ∉ acc.map (·.1) → + (insertValSorted kv acc).lookup k = if k == kv.1 then some kv.2 else acc.lookup k + | (key, val), [], k, _ => by + cases hk : k == key <;> simp [insertValSorted, List.lookup_cons, hk] + | (key, val), (key', val') :: rest, k, hfresh => by + have hne : key ≠ key' := by intro h; exact hfresh (by simp [h]) + have hrest : key ∉ rest.map (·.1) := fun h => hfresh (by simp [h]) + rw [insertValSorted] + cases h : Path.lt key key' with + | true => cases hk : k == key <;> simp [List.lookup_cons, hk] + | false => + simp only [Bool.false_eq_true, if_false, List.lookup_cons, + lookup_insertValSorted (key, val) rest k hrest] + cases hk : k == key with + | false => simp + | true => + -- `k` is the inserted key, and `key'` is a different one, so the + -- existing head is skipped rather than answering for `k`. + have h1 : k = key := by simpa using hk + have : (k == key') = false := by simp [h1, hne] + simp [this] + + +/-- No key bound twice. Spelled recursively rather than as `List.Nodup ∘ map`, +because every proof below inducts on the list and this shape is what the +induction wants. Implied by `SortedKeys`; see `distinctKeys_of_sortedKeys`. -/ +def DistinctKeys : List (Path × V) → Prop + | [] => True + | kv :: rest => kv.1 ∉ rest.map (·.1) ∧ DistinctKeys rest + +/-- Appending a fresh key to a distinct-keyed list keeps it distinct. -/ +theorem distinctKeys_append_singleton : + ∀ (acc : List (Path × V)) (kv : Path × V), + DistinctKeys acc → kv.1 ∉ acc.map (·.1) → DistinctKeys (acc ++ [kv]) + | [], kv, _, _ => ⟨by simp, trivial⟩ + | kv' :: rest, kv, hacc, hfresh => by + refine ⟨?_, distinctKeys_append_singleton rest kv hacc.2 (fun h => hfresh (by simp [h]))⟩ + intro hm + -- the goal arrives with `List.append`, which `map_append` does not match + simp only [List.append_eq, List.map_append, List.mem_append, + List.map_cons, List.map_nil, List.mem_singleton] at hm + rcases hm with hm | hm + · exact hacc.1 hm + · exact hfresh (by simp [show kv'.1 = kv.1 by simpa using hm]) + +private theorem distinctKeys_dedupAux : + ∀ (l acc : List (Path × V)), DistinctKeys acc → + DistinctKeys (l.foldl (fun acc kv => if acc.any (fun x => x.1 == kv.1) then acc else acc ++ [kv]) acc) + | [], acc, h => h + | kv :: rest, acc, h => by + rw [List.foldl_cons] + cases hany : acc.any (fun x => x.1 == kv.1) with + | true => simpa [hany] using distinctKeys_dedupAux rest acc h + | false => + have hfresh : kv.1 ∉ acc.map (·.1) := by + intro hm + obtain ⟨p, hp, hpe⟩ := List.mem_map.mp hm + have : (acc.any (fun x => x.1 == kv.1)) = true := + List.any_eq_true.mpr ⟨p, hp, by simp [hpe]⟩ + rw [hany] at this; exact Bool.noConfusion this + simpa [hany] using + distinctKeys_dedupAux rest _ (distinctKeys_append_singleton acc kv h hfresh) + +/-- `dedupVals` leaves no key bound twice. -/ +theorem distinctKeys_dedupVals (l : List (Path × V)) : DistinctKeys (dedupVals l) := by + rw [dedupVals]; exact distinctKeys_dedupAux l [] trivial + +/-- The insertion sort moves no lookup either, given distinct keys to start from. + +The two hypotheses are what make the *last* insertion win in `insertValSorted` +agree with the *first* binding won by `lookup`: with distinct keys there is only +one of each. -/ +private theorem lookup_sortAux (k : Path) : + ∀ (ds acc : List (Path × V)), DistinctKeys ds → + (∀ x ∈ ds.map (·.1), x ∉ acc.map (·.1)) → + (ds.foldl (fun acc kv => insertValSorted kv acc) acc).lookup k + = (ds.lookup k).or (acc.lookup k) + | [], acc, _, _ => by simp + | kv :: rest, acc, hd, hdisj => by + have hfresh : kv.1 ∉ acc.map (·.1) := hdisj kv.1 (by simp) + have hdisj' : ∀ x ∈ rest.map (·.1), x ∉ (insertValSorted kv acc).map (·.1) := by + intro x hx hmem + rcases (mem_keys_insertValSorted kv acc x).mp hmem with h | h + · exact hd.1 (h ▸ hx) + · exact hdisj x (by simp [hx]) h + rw [List.foldl_cons, lookup_sortAux k rest _ hd.2 hdisj', + lookup_insertValSorted kv acc k hfresh, List.lookup_cons] + cases hk : k == kv.1 with + | true => + have : rest.lookup k = none := + lookup_eq_none_of_not_mem_keys (by + rw [show k = kv.1 by simpa using hk]; exact hd.1) + simp [this] + | false => simp + +/-- **`normVals` preserves every lookup.** Canonicalisation reorders and +deduplicates; it does not change what the list holds anywhere. -/ +theorem lookup_normVals (l : List (Path × V)) (k : Path) : + (normVals l).lookup k = l.lookup k := by + rw [normVals, lookup_sortAux k (dedupVals l) [] (distinctKeys_dedupVals l) (by simp)] + simp [lookup_dedupVals] + +/-! ## List comprehensions keyed by their own elements -/ + +/-- `lookup` into a list comprehension keyed by its own elements. -/ +theorem lookup_filterMap_self (f : Path → Option V) : + ∀ (l : List Path) (k : Path), + ((l.filterMap fun x => (f x).map (Prod.mk x)).lookup k) = if k ∈ l then f k else none + | [], k => by simp + | x :: rest, k => by + rw [List.filterMap_cons] + cases hfx : f x with + | none => + simp only [Option.map_none, List.mem_cons, + lookup_filterMap_self f rest k] + by_cases hkx : k = x + · simp [hkx, hfx] + · simp [hkx] + | some v => + simp only [Option.map_some, List.lookup_cons, List.mem_cons, + lookup_filterMap_self f rest k] + cases hk : k == x with + | true => simp [show k = x by simpa using hk, hfx] + | false => simp [show ¬ (k = x) by simpa using hk] + +/-- `Path.insertSorted` adds the inserted path and keeps the rest. -/ +theorem Path.mem_insertSorted (p : Path) : + ∀ (acc : List Path) (x : Path), x ∈ Path.insertSorted p acc ↔ (x = p ∨ x ∈ acc) + | [], x => by simp [Path.insertSorted] + | q :: qs, x => by + rw [Path.insertSorted] + cases hpq : p == q with + | true => + have hpq' : p = q := by simpa using hpq + simp only [if_pos, List.mem_cons] + constructor + · intro h; exact Or.inr h + · intro h + rcases h with h | h + · exact Or.inl (by rw [h, hpq']) + · exact h + | false => + cases hlt : Path.lt p q with + | true => simp + | false => + simp only [Bool.false_eq_true, if_false, List.mem_cons, + Path.mem_insertSorted p qs x] + constructor + · intro h + rcases h with h | h | h + · exact Or.inr (Or.inl h) + · exact Or.inl h + · exact Or.inr (Or.inr h) + · intro h + rcases h with h | h | h + · exact Or.inr (Or.inl h) + · exact Or.inl h + · exact Or.inr (Or.inr h) + +private theorem Path.mem_sortAux : + ∀ (ps acc : List Path) (x : Path), + x ∈ ps.foldl (fun acc p => Path.insertSorted p acc) acc ↔ (x ∈ ps ∨ x ∈ acc) + | [], acc, x => by simp + | p :: rest, acc, x => by + rw [List.foldl_cons, Path.mem_sortAux rest _ x, Path.mem_insertSorted] + simp only [List.mem_cons] + constructor + · intro h + rcases h with h | h | h + · exact Or.inl (Or.inr h) + · exact Or.inl (Or.inl h) + · exact Or.inr h + · intro h + rcases h with (h | h) | h + · exact Or.inr (Or.inl h) + · exact Or.inl h + · exact Or.inr (Or.inr h) + +/-- Sorting and deduplicating a path list keeps exactly its members. -/ +theorem Path.mem_sortDedup (ps : List Path) (x : Path) : + x ∈ Path.sortDedup ps ↔ x ∈ ps := by + rw [Path.sortDedup] + simpa using Path.mem_sortAux ps [] x + +/-! ## Sortedness, and the uniqueness of the canonical form -/ + +/-- Entry keys strictly increasing. Strictness folds distinctness in, so this +one predicate is the whole canonical-form invariant. -/ +def SortedKeys : List (Path × V) → Prop + | [] => True + | kv :: rest => (∀ x ∈ rest.map (·.1), Path.lt kv.1 x = true) ∧ SortedKeys rest + +/-- A path strictly below every key of a list is not one of them. -/ +theorem notMem_keys_of_all_lt {l : List (Path × V)} {k : Path} + (h : ∀ x ∈ l.map (·.1), Path.lt k x = true) : k ∉ l.map (·.1) := by + intro hm + have := h k hm + rw [Path.lt_irrefl] at this + exact Bool.noConfusion this + +/-- …so it looks up to nothing. -/ +theorem lookup_eq_none_of_all_lt {l : List (Path × V)} {k : Path} + (h : ∀ x ∈ l.map (·.1), Path.lt k x = true) : l.lookup k = none := + lookup_eq_none_of_not_mem_keys (notMem_keys_of_all_lt h) + +/-- A sorted list's head key is below every key after it, and so is anything +below the head key. -/ +theorem all_lt_of_lt_head {kv : Path × V} {rest : List (Path × V)} {k : Path} + (hs : SortedKeys (kv :: rest)) (hlt : Path.lt k kv.1 = true) : + ∀ x ∈ (kv :: rest).map (·.1), Path.lt k x = true := by + intro x hx + simp only [List.map_cons, List.mem_cons] at hx + rcases hx with hx | hx + · exact hx ▸ hlt + · exact Path.lt_trans hlt (hs.1 x hx) + +theorem sortedKeys_insertValSorted : + ∀ (kv : Path × V) (acc : List (Path × V)), SortedKeys acc → kv.1 ∉ acc.map (·.1) → + SortedKeys (insertValSorted kv acc) + | kv, [], _, _ => ⟨by simp, trivial⟩ + | kv, kv' :: rest, hs, hfresh => by + have hne : kv.1 ≠ kv'.1 := fun h => hfresh (by simp [h]) + have hrest : kv.1 ∉ rest.map (·.1) := fun h => hfresh (by simp [h]) + rw [insertValSorted] + cases hlt : Path.lt kv.1 kv'.1 with + | true => + exact ⟨all_lt_of_lt_head hs hlt, hs⟩ + | false => + -- not below `kv'`, and not equal to it, so strictly above it + have hgt : Path.lt kv'.1 kv.1 = true := by + rcases Path.lt_total kv.1 kv'.1 with h | h | h + · rw [h] at hlt; exact Bool.noConfusion hlt + · exact absurd h hne + · exact h + refine ⟨?_, sortedKeys_insertValSorted kv rest hs.2 hrest⟩ + intro x hx + rcases (mem_keys_insertValSorted kv rest x).mp hx with hx | hx + · exact hx ▸ hgt + · exact hs.1 x hx + +private theorem sortedKeys_sortAux : + ∀ (ds acc : List (Path × V)), DistinctKeys ds → SortedKeys acc → + (∀ x ∈ ds.map (·.1), x ∉ acc.map (·.1)) → + SortedKeys (ds.foldl (fun acc kv => insertValSorted kv acc) acc) + | [], acc, _, hs, _ => hs + | kv :: rest, acc, hd, hs, hdisj => by + have hfresh : kv.1 ∉ acc.map (·.1) := hdisj kv.1 (by simp) + have hdisj' : ∀ x ∈ rest.map (·.1), x ∉ (insertValSorted kv acc).map (·.1) := by + intro x hx hmem + rcases (mem_keys_insertValSorted kv acc x).mp hmem with h | h + · exact hd.1 (h ▸ hx) + · exact hdisj x (by simp [hx]) h + rw [List.foldl_cons] + exact sortedKeys_sortAux rest _ hd.2 (sortedKeys_insertValSorted kv acc hs hfresh) hdisj' + +/-- Canonicalisation really does canonicalise. -/ +theorem sortedKeys_normVals (l : List (Path × V)) : SortedKeys (normVals l) := by + rw [normVals] + exact sortedKeys_sortAux (dedupVals l) [] (distinctKeys_dedupVals l) trivial (by simp) + +/-- **The canonical form is unique.** Two sorted entry lists with the same +lookup are the same list. -/ +theorem eq_of_sortedKeys_of_lookup : + ∀ (l₁ l₂ : List (Path × V)), SortedKeys l₁ → SortedKeys l₂ → + (∀ k, l₁.lookup k = l₂.lookup k) → l₁ = l₂ + | [], [], _, _, _ => rfl + | [], (k₂, v₂) :: r₂, _, _, h => by + have := h k₂; simp at this + | (k₁, v₁) :: r₁, [], _, _, h => by + have := h k₁; simp at this + | (k₁, v₁) :: r₁, (k₂, v₂) :: r₂, hs₁, hs₂, h => by + -- Neither head key can be the smaller one, so they are equal. + have hkey : k₁ = k₂ := by + rcases Path.lt_total k₁ k₂ with hlt | heq | hgt + · exact absurd (h k₁) (by + rw [lookup_eq_none_of_all_lt (all_lt_of_lt_head hs₂ hlt)] + simp) + · exact heq + · exact absurd (h k₂) (by + rw [lookup_eq_none_of_all_lt (all_lt_of_lt_head hs₁ hgt)] + simp) + subst hkey + have hval : v₁ = v₂ := by + have := h k₁; simp at this; exact this + subst hval + -- The tails then agree everywhere: at `k₁` both are `none` by strictness. + have htail : r₁ = r₂ := by + refine eq_of_sortedKeys_of_lookup r₁ r₂ hs₁.2 hs₂.2 (fun k => ?_) + by_cases hk : k = k₁ + · subst hk + rw [lookup_eq_none_of_not_mem_keys (notMem_keys_of_all_lt hs₁.1), + lookup_eq_none_of_not_mem_keys (notMem_keys_of_all_lt hs₂.1)] + · have := h k + simp only [List.lookup_cons, show (k == k₁) = false by simp [hk]] at this + exact this + rw [htail] + +/-- **Sorted implies distinct.** `SortedKeys` asks each key to be *strictly* +below every key after it, and `Path.lt` is irreflexive, so no key can appear +twice. One predicate therefore carries the whole canonical-form invariant, which +is why `PrunedMap` needs only the single proof field. -/ +theorem distinctKeys_of_sortedKeys : + ∀ {l : List (Path × V)}, SortedKeys l → DistinctKeys l + | [], _ => trivial + | _ :: _, hs => ⟨notMem_keys_of_all_lt hs.1, distinctKeys_of_sortedKeys hs.2⟩ + +end PrunedModel diff --git a/lean/PrunedModel/Fuzz.lean b/lean/PrunedModel/Fuzz.lean new file mode 100644 index 00000000..534f9aaf --- /dev/null +++ b/lean/PrunedModel/Fuzz.lean @@ -0,0 +1,533 @@ +import PrunedModel.Spec + +/-! +# Differential-fuzzing front end for the dangling-path-free subset + +This module turns `PrunedModel` into an **oracle**: it decodes a raw fuzzer +input into a program over two maps and two zippers, runs it, and emits a trace. +`differential/src/pruned.rs` decodes the *same bytes* with the *same* rules and +emits the *same* trace format from the real crate, so a behavioural divergence +is a textual diff. `lean/pruned_differential.py` drives the pair. + +## How this differs from `PathMapModel.Fuzz` + +That harness explores the whole zipper API and reproduces whatever `pathmap` +does with dangling paths, including the parts nobody wants. Its prune flags are +therefore pinned to `false` and compared against nothing, because the flag's +effect is a function of where an internal node boundary happens to fall. + +This one explores a smaller API and makes a stronger claim about it. Three +restrictions define the subset: + +1. **No `create_path`.** Its whole purpose is a location with no value. +2. **`prune = true` everywhere.** Removal here is inherently pruning: a chain + that exists only to reach a value goes when the value does. `prune_path` and + `prune_ascend` stay in the table as *assertions* — the model says `0`, so a + non-zero count from the crate means something in the subset leaked a dangling + path for it to find. +3. **The write zipper is rooted at the map root.** A write zipper rooted below + it holds a node at its own root, which survives as a location leading nowhere + once everything beneath is removed, and `prune_path` is documented not to rise + above the zipper's origin. That is outside the model by construction rather + than by a bug. Off-root *writing* is still covered: the root-rooted zipper + reaches every focus with `descend_to`. + +The read zipper may be rooted anywhere that exists. Its root is decoded as a +path and then clamped to its longest existing prefix, so it is never a location +the seeding did not create — a read zipper whose root does not exist can walk +out of it (FINDINGS.md #3), which would contaminate every other comparison. + +Operations that *can* still leave a dangling path in `pathmap` 0.4.0 are +specified, not skipped. `graft` of an empty source is the clearest: the focus +loses its value and its branches, so the model removes it and the chain above +it, while the crate leaves both behind. Producing those divergences is what +this harness is for. + +## Wire format + +The input is consumed one byte at a time; decoding stops, and the program ends, +as soon as the input runs out. + +``` +header: + n := u8 % 8 -- entries seeded into map0 (the write target) + n × ( len := u8 % 6 ; len × pathbyte ; val := u8 ) + n := u8 % 8 -- entries seeded into map1 (the read source) + n × ( len := u8 % 6 ; len × pathbyte ; val := u8 ) + r1 := u8 % 4 ; r1 × pathbyte -- read zipper root, clamped to its + -- longest existing prefix +body: + repeated: op := u8 % 54 ; operands per op (see `step`) +``` + +Every **path byte** is masked to `b % 4`, so generated tries share prefixes +heavily — that is where the interesting shapes (branch points, single-child +runs, chains that exist only to reach one value) live. + +## Trace format + +One line per operation: + +``` + ret= W= o e<0|1> v c n f R=<...> +``` + +followed by a dump of both maps. Values are decimal, paths lowercase hex, `e` +is `path_exists`, `c` is `child_count`, `n` is `val_count`. A location with no +value renders as `-`, so a dangling path the crate left behind shows up in the +dump as an entry the model does not have. +-/ + +namespace PrunedModel +namespace Fuzz + +open PathMapModel + +/-- The value type the harness uses: `PathMap`. -/ +abbrev V := UInt64 +/-- The `Lattice`/`DistributiveLattice` instance `pathmap` provides for `u64`. -/ +def ops : ValOps V := u64Ops + +/-! ## Skip reasons + +Why an operation was skipped. Every `skip` in the trace carries one, so a +skipped op says which rule declined it. `differential/src/pruned.rs` emits the +same tokens; the two must agree exactly or every input with a skip diverges. + +Note which reasons from `PathMapModel.Fuzz` are *absent*: `skip:act` (there is +one read source here), `skip:off-root-prune` (the write zipper is always at the +map root, so the prune count is well-defined), and `skip:quarantined` +(`graft_child_maps` is not in this table at all). -/ + +/-- `to_next`/`to_prev_sibling_byte` at the zipper root, where the native read +zipper escapes its own root. -/ +def skipAtRoot : String := "skip:at-root" +/-- The focus has nothing below it, where the op's behaviour is a function of +node materialisation rather than of trie state. -/ +def skipEmptyFocus : String := "skip:empty-focus" + +/-! ## Rendering -/ + +def hexDigit (n : Nat) : Char := + if n < 10 then Char.ofNat (48 + n) else Char.ofNat (87 + n) + +def hexByte (b : UInt8) : String := + let n := b.toNat + String.ofList [hexDigit (n / 16), hexDigit (n % 16)] + +def hexPath (p : Path) : String := + if p.isEmpty then "_" else String.join (p.map hexByte) + +/-- The byte a movement operation moved to, or `-` for "did not move". -/ +def showByteOpt : Option UInt8 → String + | none => "-" + | some b => hexByte b + +def showVal : Option V → String + | none => "-" + | some v => toString v.toNat + +def showBool (b : Bool) : String := if b then "1" else "0" + +/-- One location of a dump: its path, relative to `root`, and its value. -/ +def showEntry (t : PrunedMap V) (root : Path) (q : Path) : String := + hexPath q ++ ":" ++ showVal (t.valAt (root ++ q)) + +/-- All locations at and below `root`, depth-first, capped so a runaway trie +cannot make the trace unbounded. + +Every entry here *should* carry a value or lead to one. An entry rendering `-` +with nothing below it is a dangling path, which is the divergence this harness +exists to find. -/ +def dumpAt (t : PrunedMap V) (root : Path) : String := + let qs := (t.subtrie root).paths.take 64 + String.intercalate "," (qs.map (showEntry t root)) + +/-! ## Decoder -/ + +/-- A cursor over the fuzzer's input bytes. -/ +structure Dec where + bytes : ByteArray + pos : Nat + +/-- Read one byte; `none` once the input is exhausted, which ends the program. -/ +def Dec.u8 (d : Dec) : Option (UInt8 × Dec) := + if h : d.pos < d.bytes.size then some (d.bytes[d.pos]'h, { d with pos := d.pos + 1 }) + else none + +/-- Read one byte reduced modulo `m`. -/ +def Dec.mod (d : Dec) (m : Nat) : Option (Nat × Dec) := + d.u8.map (fun (b, d') => (if m == 0 then 0 else b.toNat % m, d')) + +/-- Read one *path* byte. Masked to a 4-letter alphabet so generated tries +share prefixes and actually branch. -/ +def Dec.pathByte (d : Dec) : Option (UInt8 × Dec) := + d.u8.map (fun (b, d') => (UInt8.ofNat (b.toNat % 4), d')) + +/-- Read `n` path bytes. -/ +def Dec.pathN (d : Dec) : Nat → Option (Path × Dec) + | 0 => some ([], d) + | n + 1 => do + let (b, d) ← d.pathByte + let (rest, d) ← d.pathN n + some (b :: rest, d) + +/-- Read a length-prefixed path (`len := u8 % lim`). -/ +def Dec.path (d : Dec) (lim : Nat := 6) : Option (Path × Dec) := do + let (n, d) ← d.mod lim + d.pathN n + +/-- Read a boolean (`u8 % 2`). -/ +def Dec.bool (d : Dec) : Option (Bool × Dec) := + d.u8.map (fun (b, d') => (b.toNat % 2 == 1, d')) + +/-! ## Interpreter state -/ + +/-- Two maps, two zippers: `wz` writes into map0 and is rooted at its root, `rz` +reads map1. Keeping the read source in a separate map is what lets the real +crate hold both zippers at once. -/ +structure St where + wz : PZip V + rz : PZip V + out : List String + step : Nat + +/-- The per-step fingerprint of one zipper. -/ +def fingerprint (z : PZip V) : String := + hexPath z.path ++ " o" ++ hexPath z.focus ++ + " e" ++ showBool z.pathExists ++ + " v" ++ showVal z.val ++ " c" ++ toString z.childCount ++ + " n" ++ toString z.valCount ++ + -- `focus_byte` is unspecified at the root, so it is only compared below it. + " f" ++ (if z.atRoot then "?" else showByteOpt z.focusByte) + +def emit (s : St) (name : String) (ret : String) : St := + { s with + out := (toString s.step ++ " " ++ name ++ " ret=" ++ ret ++ + " W=" ++ fingerprint s.wz ++ " R=" ++ fingerprint s.rz) :: s.out + step := s.step + 1 } + +/-! ## The operation table + +`op % nops` selects the operation. Ops `0`–`29` act on a target zipper chosen +by a following `u8 % 2` byte (`0` = write zipper, `1` = read zipper); ops +`30`–`53` are write-zipper operations. -/ + +/-- Number of distinct operations. Must match `NOPS` in +`differential/src/pruned.rs`. -/ +def nops : Nat := 54 + +/-- A full `k`-path iteration: `descend_first_k_path` followed by +`to_next_k_path` until it runs out (capped at 32 stops). Returns the locations +visited. This is the only well-defined way to use the `k`-path primitives: +`k_path_internal` carries iteration state, so calling `to_next_k_path` cold is +flagged by `pathmap`'s own debug assertions. -/ +def kWalk (z : PZip V) (k : Nat) : List Path × PZip V := + let (ok, z1) := z.descendFirstKPath k + if !ok then ([], z1) else go 31 z1 [z1.path] +where + go : Nat → PZip V → List Path → List Path × PZip V + | 0, z, acc => (acc.reverse, z) + | n + 1, z, acc => + let (moved, z') := z.toNextKPath k + if moved then go n z' (z'.path :: acc) else (acc.reverse, z') + +/-- Apply `f` to the zipper selected by `t`. -/ +def onTarget (s : St) (t : Nat) (f : PZip V → α × PZip V) : α × St := + if t == 0 then let (a, z) := f s.wz; (a, { s with wz := z }) + else let (a, z) := f s.rz; (a, { s with rz := z }) + +/-- Apply an observing operation to the zipper selected by `t`. -/ +def onTargetObs (s : St) (t : Nat) (f : PZip V → Bool × Path × PZip V) : Bool × Path × St := + if t == 0 then let (a, o, z) := f s.wz; (a, o, { s with wz := z }) + else let (a, o, z) := f s.rz; (a, o, { s with rz := z }) + +/-- Read the zipper selected by `t`. -/ +def getTarget (s : St) (t : Nat) : PZip V := if t == 0 then s.wz else s.rz + +/-- Decode and run one operation. `none` means the input ran out mid-operation, +which ends the program. -/ +def step (s : St) (d : Dec) : Option (St × Dec) := do + let (opRaw, d) ← d.u8 + let op := opRaw.toNat % nops + match op with + -- ## Movement and reading, on either zipper + | 0 => do let (t, d) ← d.mod 2; let (p, d) ← d.path + let (_, s) := onTarget s t (fun z => ((), z.descendTo p)) + some (emit s "descend_to" (hexPath p), d) + | 1 => do let (t, d) ← d.mod 2; let (b, d) ← d.pathByte + let (_, s) := onTarget s t (fun z => ((), z.descendToByte b)) + some (emit s "descend_to_byte" (hexByte b), d) + | 2 => do let (t, d) ← d.mod 2; let (n, d) ← d.mod 8 + let (r, s) := onTarget s t (fun z => z.ascend n) + some (emit s "ascend" (toString r), d) + | 3 => do let (t, d) ← d.mod 2 + let (r, s) := onTarget s t (fun z => z.ascendByte) + some (emit s "ascend_byte" (showBool r), d) + | 4 => do let (t, d) ← d.mod 2 + let (_, s) := onTarget s t (fun z => ((), z.reset)) + some (emit s "reset" "-", d) + | 5 => do let (t, d) ← d.mod 2 + let (r, s) := onTarget s t (fun z => z.descendFirstByte) + some (emit s "descend_first_byte" (showByteOpt r), d) + | 6 => do let (t, d) ← d.mod 2 + let (r, s) := onTarget s t (fun z => z.descendLastByte) + some (emit s "descend_last_byte" (showByteOpt r), d) + | 7 => do let (t, d) ← d.mod 2; let (i, d) ← d.mod 6 + let (r, s) := onTarget s t (fun z => z.descendIndexedByte i) + some (emit s "descend_indexed_byte" (showByteOpt r), d) + | 8 => do let (t, d) ← d.mod 2 + let (r, s) := onTarget s t (fun z => z.descendUntil) + some (emit s "descend_until" (showBool r), d) + | 9 => do let (t, d) ← d.mod 2 + let (r, s) := onTarget s t (fun z => z.ascendUntil) + some (emit s "ascend_until" (toString r), d) + | 10 => do let (t, d) ← d.mod 2 + let (r, s) := onTarget s t (fun z => z.ascendUntilBranch) + some (emit s "ascend_until_branch" (toString r), d) + | 11 => do let (t, d) ← d.mod 2 + -- Skipped at the zipper root: `ReadZipper::to_next_sibling_byte` + -- escapes its own root there. + if (getTarget s t).atRoot then some (emit s "to_next_sibling_byte" skipAtRoot, d) + else + let (r, s) := onTarget s t (fun z => z.toNextSiblingByte) + some (emit s "to_next_sibling_byte" (showByteOpt r), d) + | 12 => do let (t, d) ← d.mod 2 + if (getTarget s t).atRoot then some (emit s "to_prev_sibling_byte" skipAtRoot, d) + else + let (r, s) := onTarget s t (fun z => z.toPrevSiblingByte) + some (emit s "to_prev_sibling_byte" (showByteOpt r), d) + | 13 => do let (t, d) ← d.mod 2 + let (r, s) := onTarget s t (fun z => z.toNextStep) + some (emit s "to_next_step" (showBool r), d) + | 14 => do let (_t, d) ← d.mod 2 + -- `ZipperIteration` is read-only: the target byte is still + -- consumed, but the operation always applies to the read zipper. + let (r, z) := s.rz.toNextVal + some (emit { s with rz := z } "to_next_val" (showBool r), d) + | 15 => do let (_t, d) ← d.mod 2; let (k, d) ← d.mod 4 + -- `k = 0` is specified: `false`, focus untouched. `kPathFrom` + -- gives that with no special case, since it wants a location + -- strictly after the focus and the only one at depth base+0 is the + -- focus itself. + let (r, z) := s.rz.descendFirstKPath k + some (emit { s with rz := z } "descend_first_k_path" (showBool r), d) + | 16 => do let (_t, d) ← d.mod 2; let (k, d) ← d.mod 4 + -- The op is the whole walk, not one step; see `kWalk`. With + -- `k = 0` the descent fails, so the walk is empty and the + -- never-ending `to_next_k_path(0)` is not reached. + let (ps, z) := kWalk s.rz k + some (emit { s with rz := z } "k_path_walk" + (String.intercalate "," (ps.map hexPath)), d) + | 17 => do let (_t, d) ← d.mod 2 + let (r, z) := s.rz.descendLastPath + some (emit { s with rz := z } "descend_last_path" (showBool r), d) + | 18 => do let (t, d) ← d.mod 2; let (p, d) ← d.path + let (n, s) := onTarget s t (fun z => z.moveToPath p) + some (emit s "move_to_path" (toString n), d) + | 19 => do let (t, d) ← d.mod 2; let (p, d) ← d.path + let (n, s) := onTarget s t (fun z => z.descendToExisting p) + some (emit s "descend_to_existing" (toString n), d) + | 20 => do let (t, d) ← d.mod 2; let (p, d) ← d.path + let (n, s) := onTarget s t (fun z => z.descendToVal p) + some (emit s "descend_to_val" (toString n), d) + | 21 => do let (t, d) ← d.mod 2; let (b, d) ← d.pathByte + let (r, s) := onTarget s t (fun z => z.descendToExistingByte b) + some (emit s "descend_to_existing_byte" (showBool r), d) + | 22 => do let (t, d) ← d.mod 2; let (n, d) ← d.mod 8 + let (r, s) := onTarget s t (fun z => z.descendUntilMaxBytes n) + some (emit s "descend_until_max_bytes" (showBool r), d) + | 23 => do let (t, d) ← d.mod 2; let (p, d) ← d.path + let (r, s) := onTarget s t (fun z => z.descendToCheck p) + some (emit s "descend_to_check" (showBool r), d) + | 24 => do let (t, d) ← d.mod 2; let (p, d) ← d.path + let z := getTarget s t + some (emit s "val_at" (showVal (z.valAt p)), d) + | 25 => do let (t, d) ← d.mod 2 + let z := getTarget s t + some (emit s "make_map_val_count" (toString (z.makeMap.valCount [])), d) + | 26 => do let (t, d) ← d.mod 2 + let z := getTarget s t + some (emit s "dump" (dumpAt z.trie z.focus), d) + | 27 => do let (t, d) ← d.mod 2 + -- The blind-zipper addition: `descend_until` reporting the bytes + -- it descended. The observer's output is a blind zipper's only + -- account of where it went, so it is compared byte for byte. + let (r, obs, s) := onTargetObs s t (fun z => z.descendUntilObserved) + some (emit s "descend_until_observed" (showBool r ++ ":" ++ hexPath obs), d) + | 28 => do let (t, d) ← d.mod 2; let (p, d) ← d.path + -- `ZipperReadOnlyValues::get_val`/`get_val_at` differ from + -- `val`/`val_at` only in the lifetime of the reference they + -- return, so they must give the same answer. `agree` is `1` in + -- the model by construction; a `0` from the crate is the point. + let z := getTarget s t + some (emit s "get_val_agrees" + (showVal z.val ++ ":" ++ showVal (z.valAt p) ++ ":1"), d) + | 29 => do -- `ZipperReadOnlyIteration::to_next_get_val` must advance exactly + -- as `to_next_val` does and hand back the value at the new focus. + let (moved, z) := s.rz.toNextVal + let v := if moved then z.val else none + some (emit { s with rz := z } "to_next_get_val" + (showBool moved ++ ":" ++ showVal v ++ ":1"), d) + -- ## Writing, on the write zipper + | 30 => do let (v, d) ← d.u8 + let (old, z) := s.wz.setVal (UInt64.ofNat v.toNat) + some (emit { s with wz := z } "set_val" (showVal old), d) + | 31 => do let (old, z) := s.wz.removeVal + some (emit { s with wz := z } "remove_val" (showVal old), d) + | 32 => do -- Must be `0`: a trie built from this subset has no dangling tip. + let (n, z) := s.wz.prunePath + some (emit { s with wz := z } "prune_path" (toString n), d) + | 33 => do let (n, z) := s.wz.pruneAscend + some (emit { s with wz := z } "prune_ascend" (toString n), d) + | 34 => do let leaky := s.wz.focusNodeIsEmpty + let (r, z) := s.wz.removeBranches + -- An empty node still comes back as `Some(..)` from + -- `into_option()` for some representations, so `true` gets + -- reported for a removal of nothing. Compared only when there was + -- something below. + some (emit { s with wz := z } "remove_branches" + (if leaky then "?" else showBool r), d) + | 35 => do let (n, d) ← d.mod 4; let (m, d) ← d.pathN n + let z := s.wz.removeUnmaskedBranches (ByteMask.ofList m) + some (emit { s with wz := z } "remove_unmasked_branches" + (hexPath (ByteMask.ofList m)), d) + | 36 => do let z := s.wz.graft s.rz + some (emit { s with wz := z } "graft" "-", d) + | 37 => do let (p, d) ← d.path + let z := s.wz.graftSrcAt s.rz p + some (emit { s with wz := z } "graft_src_at" (hexPath p), d) + | 38 => do let (st, z) := s.wz.joinInto ops s.rz + some (emit { s with wz := z } "join_into" (toString st), d) + | 39 => do let leaky := s.wz.focusNodeIsEmpty + let (st, z) := s.wz.joinMapInto ops s.rz.makeMap + some (emit { s with wz := z } "join_map_into" + (if leaky then "?" else toString st), d) + | 40 => do let (st, z) := s.wz.meetInto ops s.rz + some (emit { s with wz := z } "meet_into" (toString st), d) + | 41 => do let (st, z) := s.wz.subtractInto ops s.rz + some (emit { s with wz := z } "subtract_into" (toString st), d) + | 42 => do let leaky := s.wz.focusNodeIsEmpty + let (st, z) := s.wz.restrict ops s.rz + some (emit { s with wz := z } "restrict" + (if leaky then "?" else toString st), d) + | 43 => do -- Skipped, not merely masked, when either side has nothing below + -- its focus: there `restricting` branches on whether an empty node + -- happens to be materialised, and the two branches differ in + -- *effect*, not just in the reported bool. + if s.wz.focusNodeIsEmpty || s.rz.focusNodeIsEmpty then + some (emit s "restricting" skipEmptyFocus, d) + else + let (r, z) := s.wz.restricting s.rz + some (emit { s with wz := z } "restricting" (showBool r), d) + | 44 => do let (k, d) ← d.mod 4 + let (r, z) := s.wz.joinKPathInto ops k + some (emit { s with wz := z } "join_k_path_into" + (if z.focusNodeIsEmpty then "?" else showBool r), d) + | 45 => do let (p, d) ← d.path + let (r, z) := s.wz.insertPrefix p + some (emit { s with wz := z } "insert_prefix" (showBool r), d) + | 46 => do let (n, d) ← d.mod 6 + let (r, z) := s.wz.removePrefix n + some (emit { s with wz := z } "remove_prefix" (toString r), d) + | 47 => do let leaky := s.wz.focusNodeIsEmpty && s.wz.val.isNone + let (m, z) := s.wz.takeMap + if leaky then + some (emit { s with wz := (z.graftMap (m.getD PrunedMap.empty)) } + "take_map_restore" "?", d) + else + match m with + | some mm => some (emit { s with wz := z.graftMap mm } "take_map_restore" "1", d) + | none => some (emit { s with wz := z } "take_map_restore" "0", d) + | 48 => do let (k, d) ← d.mod 4 + let (r, z) := s.wz.meetKPathInto ops k + some (emit { s with wz := z } "meet_k_path_into" (showBool r), d) + | 49 => do let (v, d) ← d.u8 + -- Writing through the reference `get_val_mut` hands back. It must + -- behave like `set_val` where a value exists and do nothing -- + -- crucially, *not* create the path -- where one does not. + let (old, z) := s.wz.getValMutWrite (UInt64.ofNat v.toNat) + some (emit { s with wz := z } "get_val_mut_write" (showVal old), d) + | 50 => do let (v, d) ← d.u8 + let (r, z) := s.wz.getValOrSetMut (UInt64.ofNat v.toNat) + some (emit { s with wz := z } "get_val_or_set_mut" (showVal (some r)), d) + | 51 => do let (v, d) ← d.u8 + -- `ran` records whether the closure was invoked. The contract says + -- it supplies the value "if no value exists", so invoking it when a + -- value is already present is observable to any caller whose + -- closure has a side effect. + let (r, ran, z) := s.wz.getValOrSetMutWith (UInt64.ofNat v.toNat) + some (emit { s with wz := z } "get_val_or_set_mut_with" + (showVal (some r) ++ ":" ++ showBool ran), d) + | 52 => do let (n, d) ← d.mod 4; let (m, d) ← d.pathN n; let (ru, d) ← d.bool + let z := s.wz.graftMaskedBranches s.rz (ByteMask.ofList m) ru + some (emit { s with wz := z } "graft_masked_branches" + (hexPath (ByteMask.ofList m) ++ ":" ++ showBool ru), d) + | 53 => do let (p, d) ← d.path + -- `meet_2` takes two sources; the second is the first moved to `p`. + let b := { s.rz with path := s.rz.path ++ p } + let (st, z) := s.wz.meet2 ops s.rz b + some (emit { s with wz := z } "meet_2" (toString st), d) + | _ => some (emit s "nop" "-", d) + +/-- Run operations until the input is exhausted or `fuel` runs out. -/ +def loop : Nat → St → Dec → St + | 0, s, _ => s + | n + 1, s, d => + match step s d with + | some (s', d') => loop n s' d' + | none => s + +/-! ## Header -/ + +/-- Decode `n` seed entries and insert them into `t`. -/ +def seed (t : PrunedMap V) (d : Dec) : Nat → Option (PrunedMap V × Dec) + | 0 => some (t, d) + | n + 1 => do + let (p, d) ← d.path + let (v, d) ← d.u8 + seed (t.setVal p (UInt64.ofNat v.toNat)).2 d n + +/-- The longest prefix of `p` that exists in `t`. + +The read zipper's root is clamped this way instead of being created, because +`create_path` is not in this subset. A zipper whose root does not exist can +escape it — `to_next_sibling_byte` and `to_next_step` fall back on the parent's +child mask and walk out of the granted subtrie — and that one bug would +contaminate every other comparison. -/ +def clampToExisting (t : PrunedMap V) (p : Path) : Path := + -- Existence is prefix-closed, so the prefixes that exist form an initial + -- segment and the longest one is the answer. + p.take (((List.range (p.length + 1)).filter + (fun j => t.pathExists (p.take j))).getLast?.getD 0) + +/-- Decode the header: two seeded maps and the read zipper's root. The write +zipper is always rooted at the map root; see the module docstring. -/ +def header (d : Dec) : Option (St × Dec) := do + let (n0, d) ← d.mod 8 + let (m0, d) ← seed PrunedMap.empty d n0 + let (n1, d) ← d.mod 8 + let (m1, d) ← seed PrunedMap.empty d n1 + let (r1raw, d) ← d.path 4 + let r1 := clampToExisting m1 r1raw + some ({ wz := { trie := m0, root := [], path := [] } + rz := { trie := m1, root := r1, path := [] } + out := [], step := 0 }, d) + +/-! ## Entry point -/ + +/-- Decode and run a fuzzer input, returning the trace lines. -/ +def run (bytes : ByteArray) (maxSteps : Nat := 256) : List String := + match header { bytes, pos := 0 } with + | none => ["EMPTY"] + | some (s0, d) => + let s := loop maxSteps s0 d + let final := + ("MAP0 " ++ dumpAt s.wz.trie []) :: + ("MAP1 " ++ dumpAt s.rz.trie []) :: + ("ROOT0 " ++ hexPath s.wz.root) :: + ("ROOT1 " ++ hexPath s.rz.root) :: [] + s.out.reverse ++ final + +end Fuzz +end PrunedModel diff --git a/lean/PrunedModel/Lattice.lean b/lean/PrunedModel/Lattice.lean new file mode 100644 index 00000000..bd5f6a6a --- /dev/null +++ b/lean/PrunedModel/Lattice.lean @@ -0,0 +1,496 @@ +import PrunedModel.Spec + +/-! +# The lattice laws + +`PrunedMap.join` and `PrunedMap.meet` are meant to be union and intersection. +This file proves it, in the only form that means anything: the lattice +identities, derived rather than checked on examples. + +## Why here and not in `PathMapModel` + +The laws are *false* for the other model, and instructively so. +`PathMapModel.meet` keeps a location only when it leads to a surviving value, so +a trie with a dangling path does not survive `meet a a` — idempotence fails on +exactly the states `PrunedModel` cannot represent. A specification that +reproduces the crate's dangling-path behaviour cannot also be a lattice. So +these proofs are not a bonus feature of the pruned model; they are only +available because of what it leaves out. + +## Shape of the development + +1. `valAt` sees through `mk'`: `(mk' l).valAt k = l.lookup k`. Everything rests + on this, because every operation is `mk'` of a list comprehension and every + law is then a pointwise statement about `Option V`. +2. `valAt_join` / `valAt_meet` / `valAt_sub`: each operation is *pointwise* on + `valAt`. This is the step that would be false for a model storing locations + separately from values. +3. `ext`: two maps with the same `valAt` everywhere are equal. This needs + `Path.lt` to be a strict total order, proved here, and it is what lets the + laws be stated as equations rather than as pointwise equivalences. +4. The laws for `PrunedMap V`, from a hypothesis bundle on the value operations + that does *not* include commutativity. +5. `PrunedMap Unit`, where the correspondence is exact — a trie over `()` is a + finite set of paths — and commutativity holds. +-/ + +namespace PrunedModel +namespace PrunedMap + +open PathMapModel + +variable {V : Type} + +/-! ## 1. `valAt` sees through `mk'` -/ + +/-- **`valAt` sees through `mk'`.** Canonicalisation reorders and deduplicates; +it does not change what the map holds anywhere. + +Every operation below is `mk'` of a list comprehension, so this is what turns a +statement about tries into a statement about `Option V`. -/ +theorem valAt_mk' (l : List (Path × V)) (k : Path) : (mk' l).valAt k = l.lookup k := + lookup_normVals l k + +/-! ## 2. Every operation is pointwise on `valAt` + +This is the step that would fail for a model storing locations separately from +values: there, what `meet` does at a path depends on what lies *below* it. -/ + +/-- An unbound path holds nothing. -/ +theorem valAt_eq_none_of_not_mem_keys {a : PrunedMap V} {k : Path} + (h : k ∉ a.keys) : a.valAt k = none := + lookup_eq_none_of_not_mem_keys h + +@[simp] theorem valAt_empty (k : Path) : (empty : PrunedMap V).valAt k = none := rfl + +variable (ops : ValOps V) + +/-- **Join is pointwise.** -/ +theorem valAt_join (a b : PrunedMap V) (k : Path) : + (join ops a b).valAt k = joinVal ops (a.valAt k) (b.valAt k) := by + rw [join, valAt_mk', lookup_filterMap_self] + by_cases hk : k ∈ Path.sortDedup (a.keys ++ b.keys) + · simp [hk] + · -- Outside both key lists both sides hold nothing, and `joinVal none none = none`. + have hab : k ∉ a.keys ++ b.keys := fun h => hk ((Path.mem_sortDedup _ k).mpr h) + have ha : a.valAt k = none := + valAt_eq_none_of_not_mem_keys (fun h => hab (List.mem_append.mpr (Or.inl h))) + have hb : b.valAt k = none := + valAt_eq_none_of_not_mem_keys (fun h => hab (List.mem_append.mpr (Or.inr h))) + simp [hk, ha, hb, joinVal] + +/-- **Meet is pointwise.** It enumerates `a`'s keys only, which is sound because +`meetVal none _ = none`: a path `a` does not hold cannot survive a meet. -/ +theorem valAt_meet (a b : PrunedMap V) (k : Path) : + (meet ops a b).valAt k = meetVal ops (a.valAt k) (b.valAt k) := by + rw [meet, valAt_mk', lookup_filterMap_self] + by_cases hk : k ∈ a.keys + · simp [hk] + · simp [hk, valAt_eq_none_of_not_mem_keys hk, meetVal] + +/-! ## 3. The laws + +The hypotheses are on the *value* operations, lifted to `Option V` — which is +the level `valAt_join` and `valAt_meet` hand back, and the level at which a +value type either is or is not a lattice. Commutativity is deliberately not +among them: `pathmap`'s integer instances are left-biased projections +(`pjoin` returns `Identity(SELF_IDENT)` and ignores the counterpart), so +`join` picks the destination's value on a collision and is *not* commutative. +Everything else holds. -/ + +/-- What a value type must satisfy for tries over it to form a distributive +lattice under `join` and `meet`. No commutativity; see `IsCommVals`. -/ +structure IsLatticeVals {V : Type} (ops : ValOps V) : Prop where + joinAssoc : ∀ x y z : Option V, + joinVal ops (joinVal ops x y) z = joinVal ops x (joinVal ops y z) + meetAssoc : ∀ x y z : Option V, + meetVal ops (meetVal ops x y) z = meetVal ops x (meetVal ops y z) + joinIdem : ∀ x : Option V, joinVal ops x x = x + meetIdem : ∀ x : Option V, meetVal ops x x = x + joinNone : ∀ x : Option V, joinVal ops x none = x + meetNone : ∀ x : Option V, meetVal ops x none = none + absorbMeetJoin : ∀ x y : Option V, meetVal ops x (joinVal ops x y) = x + absorbJoinMeet : ∀ x y : Option V, joinVal ops x (meetVal ops x y) = x + meetDistribJoin : ∀ x y z : Option V, + meetVal ops x (joinVal ops y z) = joinVal ops (meetVal ops x y) (meetVal ops x z) + joinDistribMeet : ∀ x y z : Option V, + joinVal ops x (meetVal ops y z) = meetVal ops (joinVal ops x y) (joinVal ops x z) + +/-- The *mirrored* absorption law: `meet (join a b) a = a`, with the join on the +left of the meet. + +In a commutative lattice this is `absorbMeetJoin` read backwards and needs no +separate assumption. `pathmap`'s join is not commutative, so the two +orientations are genuinely different statements, and only one of them is a +standard lattice axiom. Nothing in §3 needs this one — it is here because +*nesting* does: `PrunedModel/Nested.lean` lifts the lattice structure to tries +whose values are tries, and the one case of `joinDistribMeet` that no longer +collapses is exactly this law. Both of `pathmap`'s instances satisfy it. -/ +structure IsFlipAbsorb {V : Type} (ops : ValOps V) : Prop where + absorbMeetJoinFlip : ∀ x y : Option V, meetVal ops (joinVal ops x y) x = x + +/-- The extra law a *commutative* value type satisfies. `unitOps` does; +`u64Ops` does not. -/ +structure IsCommVals {V : Type} (ops : ValOps V) : Prop where + joinComm : ∀ x y : Option V, joinVal ops x y = joinVal ops y x + meetComm : ∀ x y : Option V, meetVal ops x y = meetVal ops y x + +variable {ops : ValOps V} + +/-- Two tries hold the same thing at every path. The model's observable +equality: `valAt` is the whole interface, and `beqT` — which decides +`AlgebraicStatus::Identity` — agrees with it on canonical maps. -/ +def Agree (a b : PrunedMap V) : Prop := ∀ k, a.valAt k = b.valAt k + +theorem Agree.refl (a : PrunedMap V) : Agree a a := fun _ => rfl +theorem Agree.symm {a b : PrunedMap V} (hab : Agree a b) : Agree b a := fun k => (hab k).symm +theorem Agree.trans {a b c : PrunedMap V} (hab : Agree a b) (hbc : Agree b c) : Agree a c := + fun k => (hab k).trans (hbc k) + +/-! ### Associativity -/ + +theorem join_assoc (h : IsLatticeVals ops) (a b c : PrunedMap V) : + Agree (join ops (join ops a b) c) (join ops a (join ops b c)) := by + intro k; simp only [valAt_join]; exact h.joinAssoc _ _ _ + +theorem meet_assoc (h : IsLatticeVals ops) (a b c : PrunedMap V) : + Agree (meet ops (meet ops a b) c) (meet ops a (meet ops b c)) := by + intro k; simp only [valAt_meet]; exact h.meetAssoc _ _ _ + +/-! ### Idempotence -/ + +theorem join_idem (h : IsLatticeVals ops) (a : PrunedMap V) : Agree (join ops a a) a := by + intro k; rw [valAt_join]; exact h.joinIdem _ + +theorem meet_idem (h : IsLatticeVals ops) (a : PrunedMap V) : Agree (meet ops a a) a := by + intro k; rw [valAt_meet]; exact h.meetIdem _ + +/-! ### `empty` is the identity of `join` and annihilates `meet` -/ + +theorem join_empty (h : IsLatticeVals ops) (a : PrunedMap V) : Agree (join ops a empty) a := by + intro k; rw [valAt_join, valAt_empty]; exact h.joinNone _ + +theorem meet_empty (h : IsLatticeVals ops) (a : PrunedMap V) : + Agree (meet ops a empty) (empty : PrunedMap V) := by + intro k; rw [valAt_meet, valAt_empty]; exact h.meetNone _ + +/-! ### Absorption -/ + +theorem absorb_meet_join (h : IsLatticeVals ops) (a b : PrunedMap V) : Agree (meet ops a (join ops a b)) a := by + intro k; rw [valAt_meet, valAt_join]; exact h.absorbMeetJoin _ _ + +theorem absorb_join_meet (h : IsLatticeVals ops) (a b : PrunedMap V) : Agree (join ops a (meet ops a b)) a := by + intro k; rw [valAt_join, valAt_meet]; exact h.absorbJoinMeet _ _ + +/-- The mirrored absorption, at trie level. -/ +theorem absorb_meet_join_flip (hf : IsFlipAbsorb ops) (a b : PrunedMap V) : + Agree (meet ops (join ops a b) a) a := by + intro k; rw [valAt_meet, valAt_join]; exact hf.absorbMeetJoinFlip _ _ + +/-! ### Distributivity, both ways -/ + +theorem meet_distrib_join (h : IsLatticeVals ops) (a b c : PrunedMap V) : + Agree (meet ops a (join ops b c)) (join ops (meet ops a b) (meet ops a c)) := by + intro k; simp only [valAt_meet, valAt_join]; exact h.meetDistribJoin _ _ _ + +theorem join_distrib_meet (h : IsLatticeVals ops) (a b c : PrunedMap V) : + Agree (join ops a (meet ops b c)) (meet ops (join ops a b) (join ops a c)) := by + intro k; simp only [valAt_join, valAt_meet]; exact h.joinDistribMeet _ _ _ + +/-! ### Commutativity, where the value type allows it -/ + +theorem join_comm (hc : IsCommVals ops) (a b : PrunedMap V) : + Agree (join ops a b) (join ops b a) := by + intro k; simp only [valAt_join]; exact hc.joinComm _ _ + +theorem meet_comm (hc : IsCommVals ops) (a b : PrunedMap V) : + Agree (meet ops a b) (meet ops b a) := by + intro k; simp only [valAt_meet]; exact hc.meetComm _ _ + +/-! ## 4. The two instances the crate actually provides + +`u64Ops` satisfies everything but commutativity; `unitOps` satisfies +everything. -/ + +/-- `pathmap`'s integer instance gives a distributive lattice. -/ +theorem u64_isLattice : IsLatticeVals u64Ops where + joinAssoc x y z := by + cases x <;> cases y <;> cases z <;> simp [joinVal, u64Ops, ValRes.resolve] + meetAssoc x y z := by + cases x <;> cases y <;> cases z <;> simp [meetVal, u64Ops, ValRes.resolve] + joinIdem x := by cases x <;> simp [joinVal, u64Ops, ValRes.resolve] + meetIdem x := by cases x <;> simp [meetVal, u64Ops, ValRes.resolve] + joinNone x := by cases x <;> simp [joinVal] + meetNone x := by cases x <;> simp [meetVal] + absorbMeetJoin x y := by + cases x <;> cases y <;> simp [joinVal, meetVal, u64Ops, ValRes.resolve] + absorbJoinMeet x y := by + cases x <;> cases y <;> simp [joinVal, meetVal, u64Ops, ValRes.resolve] + meetDistribJoin x y z := by + cases x <;> cases y <;> cases z <;> simp [joinVal, meetVal, u64Ops, ValRes.resolve] + joinDistribMeet x y z := by + cases x <;> cases y <;> cases z <;> simp [joinVal, meetVal, u64Ops, ValRes.resolve] + +/-- …but **not** a commutative one, and this is not an artefact of the model. +`impl Lattice for u64` returns `Identity(SELF_IDENT)` from `pjoin`, ignoring the +counterpart entirely, so a collision resolves to whichever side is `self` — +which is the destination for `join_into` and the source for a join evaluated with +the operands swapped. That is also why `FINDINGS.md`'s "value bias by node +layout" class was a bug worth fixing: with a non-commutative join, *which* +operand ends up on the left is observable. -/ +theorem u64_not_isComm : ¬ IsCommVals u64Ops := by + intro hc + have h12 := hc.joinComm (some 1) (some 2) + simp only [joinVal, u64Ops, ValRes.resolve, Option.some.injEq] at h12 + exact absurd h12 (by decide) + +/-- `u64Ops` satisfies the mirrored absorption too, even though it is not +commutative: a left-biased `pjoin` makes `join x y` agree with `x` wherever `x` +has a value, which is exactly where the meet then looks. -/ +theorem u64_isFlipAbsorb : IsFlipAbsorb u64Ops where + absorbMeetJoinFlip x y := by + cases x <;> cases y <;> simp [joinVal, meetVal, u64Ops, ValRes.resolve] + +/-- `pathmap`'s `()` instance gives a distributive lattice… -/ +theorem unit_isLattice : IsLatticeVals unitOps where + joinAssoc x y z := by + cases x <;> cases y <;> cases z <;> simp [joinVal, unitOps, ValRes.resolve] + meetAssoc x y z := by + cases x <;> cases y <;> cases z <;> simp [meetVal, unitOps, ValRes.resolve] + joinIdem x := by cases x <;> simp [joinVal, unitOps, ValRes.resolve] + meetIdem x := by cases x <;> simp [meetVal, unitOps, ValRes.resolve] + joinNone x := by cases x <;> simp [joinVal] + meetNone x := by cases x <;> simp [meetVal] + absorbMeetJoin x y := by + cases x <;> cases y <;> simp [joinVal, meetVal, unitOps, ValRes.resolve] + absorbJoinMeet x y := by + cases x <;> cases y <;> simp [joinVal, meetVal, unitOps, ValRes.resolve] + meetDistribJoin x y z := by + cases x <;> cases y <;> cases z <;> simp [joinVal, meetVal, unitOps, ValRes.resolve] + joinDistribMeet x y z := by + cases x <;> cases y <;> cases z <;> simp [joinVal, meetVal, unitOps, ValRes.resolve] + +theorem unit_isFlipAbsorb : IsFlipAbsorb unitOps where + absorbMeetJoinFlip x y := by + cases x <;> cases y <;> simp [joinVal, meetVal, unitOps, ValRes.resolve] + +/-- …and a **commutative** one. There is only one value, so there is nothing for +a biased projection to be biased about. -/ +theorem unit_isComm : IsCommVals unitOps where + joinComm x y := by cases x <;> cases y <;> simp [joinVal, unitOps, ValRes.resolve] + meetComm x y := by cases x <;> cases y <;> simp [meetVal, unitOps, ValRes.resolve] + +/-! ## 5. Over `()` the correspondence is exact + +A `PrunedMap Unit` does not merely *satisfy* the set laws — it **is** a finite +set of paths. `Option Unit` has two inhabitants, so `valAt` carries exactly one +bit per path, and `join` and `meet` are that bit's `||` and `&&`. -/ + +/-- A trie over `()` holds no information beyond *which* paths are in it. -/ +theorem unit_valAt_determined (a : PrunedMap Unit) (k : Path) : + a.valAt k = if (a.valAt k).isSome then some () else none := by + cases hv : a.valAt k with + | none => simp + | some u => cases u; simp + +/-- `join` is union of those path sets. -/ +theorem unit_join_isSome (a b : PrunedMap Unit) (k : Path) : + ((join unitOps a b).valAt k).isSome = ((a.valAt k).isSome || (b.valAt k).isSome) := by + rw [valAt_join] + cases a.valAt k <;> cases b.valAt k <;> simp [joinVal, unitOps, ValRes.resolve] + +/-- `meet` is intersection of those path sets. -/ +theorem unit_meet_isSome (a b : PrunedMap Unit) (k : Path) : + ((meet unitOps a b).valAt k).isSome = ((a.valAt k).isSome && (b.valAt k).isSome) := by + rw [valAt_meet] + cases a.valAt k <;> cases b.valAt k <;> simp [meetVal, unitOps, ValRes.resolve] + +/-- `empty` is the empty set. -/ +theorem unit_empty_isSome (k : Path) : + ((empty : PrunedMap Unit).valAt k).isSome = false := by simp + +/-! Every law of §3 therefore holds for `PrunedMap Unit` with no side condition, +commutativity included: `unit_isLattice` and `unit_isComm` discharge the +hypotheses. Concretely, for `a b c : PrunedMap Unit`: + +* `join_assoc unit_isLattice a b c`, `meet_assoc unit_isLattice a b c` +* `join_comm unit_isComm a b`, `meet_comm unit_isComm a b` +* `join_idem unit_isLattice a`, `meet_idem unit_isLattice a` +* `join_empty unit_isLattice a`, `meet_empty unit_isLattice a` +* `absorb_meet_join unit_isLattice a b`, `absorb_join_meet unit_isLattice a b` +* `meet_distrib_join unit_isLattice a b c`, `join_distrib_meet unit_isLattice a b c` + +and the same list for `PrunedMap UInt64` through `u64_isLattice`, minus the two +commutativity laws, which `u64_not_isComm` rules out. + +What is *not* claimed is a Boolean algebra proper: `Path` is infinite, so there +is no top element and hence no complement. What this is, is the lattice of +finite sets of paths — a distributive lattice with a least element. The +relative complement that would make it a *generalized* Boolean algebra is +`PrunedMap.sub`, whose pointwise characterisation needs the canonicity +hypothesis that §1's `DistinctKeys` supplies; it is not proved here. -/ + +/-! ## 6. From "equal at every path" to equal + +`Agree` is the honest observational statement, and here it simply *is* equality. +`PrunedMap` carries sortedness in its type, so a trie is the unique sorted +enumeration of its own contents (`eq_of_sortedKeys_of_lookup`) and the proof +fields are `Prop`s, equal automatically. `PrunedMap.ext` does the work. + +This section used to be a hundred lines and a `Canonical` predicate every law in +§7 carried as a hypothesis. -/ + +/-- **Agreement is equality.** No side condition: there is no non-canonical trie +for one to exclude. -/ +theorem eq_of_agree {a b : PrunedMap V} (hab : Agree a b) : a = b := PrunedMap.ext hab + +/-! ## 7. The laws, as equations + +The same ten laws as §3, now as `=`, and **with no side conditions at all**. + +They used to need `Canonical a` wherever the right-hand side was the bare `a` — +idempotence, the `empty` identity, both absorptions — because the old +representation admitted an entry list binding a key twice, and such a trie is +genuinely not equal to its own join. Carrying sortedness in the type removed the +inhabitant, and with it the hypothesis. -/ + +theorem join_assoc_eq (h : IsLatticeVals ops) (a b c : PrunedMap V) : + join ops (join ops a b) c = join ops a (join ops b c) := + eq_of_agree (join_assoc h a b c) + +theorem meet_assoc_eq (h : IsLatticeVals ops) (a b c : PrunedMap V) : + meet ops (meet ops a b) c = meet ops a (meet ops b c) := + eq_of_agree (meet_assoc h a b c) + +theorem join_idem_eq (h : IsLatticeVals ops) (a : PrunedMap V) : + join ops a a = a := + eq_of_agree (join_idem h a) + +theorem meet_idem_eq (h : IsLatticeVals ops) (a : PrunedMap V) : + meet ops a a = a := + eq_of_agree (meet_idem h a) + +theorem join_empty_eq (h : IsLatticeVals ops) (a : PrunedMap V) : + join ops a empty = a := + eq_of_agree (join_empty h a) + +theorem meet_empty_eq (h : IsLatticeVals ops) (a : PrunedMap V) : + meet ops a empty = (empty : PrunedMap V) := + eq_of_agree (meet_empty h a) + +theorem absorb_meet_join_eq (h : IsLatticeVals ops) (a : PrunedMap V) (b : PrunedMap V) : meet ops a (join ops a b) = a := + eq_of_agree (absorb_meet_join h a b) + +theorem absorb_join_meet_eq (h : IsLatticeVals ops) (a : PrunedMap V) (b : PrunedMap V) : join ops a (meet ops a b) = a := + eq_of_agree (absorb_join_meet h a b) + +theorem absorb_meet_join_flip_eq (hf : IsFlipAbsorb ops) (a : PrunedMap V) (b : PrunedMap V) : meet ops (join ops a b) a = a := + eq_of_agree (absorb_meet_join_flip hf a b) + +theorem meet_distrib_join_eq (h : IsLatticeVals ops) (a b c : PrunedMap V) : + meet ops a (join ops b c) = join ops (meet ops a b) (meet ops a c) := + eq_of_agree (meet_distrib_join h a b c) + +theorem join_distrib_meet_eq (h : IsLatticeVals ops) (a b c : PrunedMap V) : + join ops a (meet ops b c) = meet ops (join ops a b) (join ops a c) := + eq_of_agree (join_distrib_meet h a b c) + +theorem join_comm_eq (hc : IsCommVals ops) (a b : PrunedMap V) : + join ops a b = join ops b a := + eq_of_agree (join_comm hc a b) + +theorem meet_comm_eq (hc : IsCommVals ops) (a b : PrunedMap V) : + meet ops a b = meet ops b a := + eq_of_agree (meet_comm hc a b) + +/-! ### Both instances, named + +Everything above is stated for an abstract `ops` under a hypothesis, so this is +where the two value types the crate provides get their own theorems — citable +rather than merely checked. `PrunedMap Unit` gets all twelve laws; +`PrunedMap UInt64` gets ten, and the two it does not get are *proved* unavailable +below. -/ + +section Instances +variable (a b c : PrunedMap Unit) (x y z : PrunedMap UInt64) + +theorem unit_join_assoc : join unitOps (join unitOps a b) c = join unitOps a (join unitOps b c) := + join_assoc_eq unit_isLattice a b c +theorem unit_meet_assoc : meet unitOps (meet unitOps a b) c = meet unitOps a (meet unitOps b c) := + meet_assoc_eq unit_isLattice a b c +theorem unit_join_comm : join unitOps a b = join unitOps b a := join_comm_eq unit_isComm a b +theorem unit_meet_comm : meet unitOps a b = meet unitOps b a := meet_comm_eq unit_isComm a b +theorem unit_join_idem : join unitOps a a = a := join_idem_eq unit_isLattice a +theorem unit_meet_idem : meet unitOps a a = a := meet_idem_eq unit_isLattice a +theorem unit_join_empty : join unitOps a empty = a := + join_empty_eq unit_isLattice a +theorem unit_meet_empty : meet unitOps a empty = empty := meet_empty_eq unit_isLattice a +theorem unit_absorb_meet_join : meet unitOps a (join unitOps a b) = a := + absorb_meet_join_eq unit_isLattice a b +theorem unit_absorb_join_meet : join unitOps a (meet unitOps a b) = a := + absorb_join_meet_eq unit_isLattice a b +theorem unit_meet_distrib_join : + meet unitOps a (join unitOps b c) = join unitOps (meet unitOps a b) (meet unitOps a c) := + meet_distrib_join_eq unit_isLattice a b c +theorem unit_join_distrib_meet : + join unitOps a (meet unitOps b c) = meet unitOps (join unitOps a b) (join unitOps a c) := + join_distrib_meet_eq unit_isLattice a b c + +theorem u64_join_assoc : join u64Ops (join u64Ops x y) z = join u64Ops x (join u64Ops y z) := + join_assoc_eq u64_isLattice x y z +theorem u64_meet_assoc : meet u64Ops (meet u64Ops x y) z = meet u64Ops x (meet u64Ops y z) := + meet_assoc_eq u64_isLattice x y z +theorem u64_join_idem : join u64Ops x x = x := join_idem_eq u64_isLattice x +theorem u64_meet_idem : meet u64Ops x x = x := meet_idem_eq u64_isLattice x +theorem u64_join_empty : join u64Ops x empty = x := + join_empty_eq u64_isLattice x +theorem u64_meet_empty : meet u64Ops x empty = empty := meet_empty_eq u64_isLattice x +theorem u64_absorb_meet_join : meet u64Ops x (join u64Ops x y) = x := + absorb_meet_join_eq u64_isLattice x y +theorem u64_absorb_join_meet : join u64Ops x (meet u64Ops x y) = x := + absorb_join_meet_eq u64_isLattice x y +theorem u64_meet_distrib_join : + meet u64Ops x (join u64Ops y z) = join u64Ops (meet u64Ops x y) (meet u64Ops x z) := + meet_distrib_join_eq u64_isLattice x y z +theorem u64_join_distrib_meet : + join u64Ops x (meet u64Ops y z) = meet u64Ops (join u64Ops x y) (join u64Ops x z) := + join_distrib_meet_eq u64_isLattice x y z +end Instances + +/-! ### Commutativity fails over `UInt64`, at the trie level + +`u64_not_isComm` rules out the *value* hypothesis, which is not quite the same +claim: a priori the asymmetry could have been invisible once lifted to tries. It +is not. Two single-path tries disagreeing only in their value are a +counterexample, so `join` and `meet` over `UInt64` are genuinely +non-commutative operations and the missing pair of laws is missing for a reason. -/ + +private def one : PrunedMap UInt64 := mk' [([0], 1)] +private def two : PrunedMap UInt64 := mk' [([0], 2)] + +theorem u64_join_not_comm : ¬ ∀ a b : PrunedMap UInt64, join u64Ops a b = join u64Ops b a := by + intro h + have hv := congrArg (fun m => m.valAt [0]) (h one two) + simp only [one, two, valAt_join, valAt_mk'] at hv + simp [joinVal, u64Ops, ValRes.resolve] at hv + +theorem u64_meet_not_comm : ¬ ∀ a b : PrunedMap UInt64, meet u64Ops a b = meet u64Ops b a := by + intro h + have hv := congrArg (fun m => m.valAt [0]) (h one two) + simp only [one, two, valAt_meet, valAt_mk'] at hv + simp [meetVal, u64Ops, ValRes.resolve] at hv + +-- The same counterexample, run rather than reasoned about: `beqT` is the +-- equality the model uses to decide `AlgebraicStatus::Identity`, and it says the +-- two orders give different tries. +#guard !(beqT u64Ops (join u64Ops one two) (join u64Ops two one)) +#guard !(beqT u64Ops (meet u64Ops one two) (meet u64Ops two one)) +#guard (join u64Ops one two).entries == [([0], (1 : UInt64))] +#guard (join u64Ops two one).entries == [([0], (2 : UInt64))] +-- …and that it is the *values* that differ, not the paths: over `()` the same +-- two tries are the same trie. +#guard beqT unitOps (join unitOps (mk' [([0], ())]) (mk' [([0], ())])) + (join unitOps (mk' [([0], ())]) (mk' [([0], ())])) + +end PrunedMap +end PrunedModel diff --git a/lean/PrunedModel/Map.lean b/lean/PrunedModel/Map.lean new file mode 100644 index 00000000..4c656157 --- /dev/null +++ b/lean/PrunedModel/Map.lean @@ -0,0 +1,306 @@ +import PrunedModel.Canon + +/-! +# A trie with no dangling paths + +## Why a second model + +`PathMapModel` models a `pathmap` trie as `List (Path × Option V)`: every +location that exists, carrying its value *if it has one*. That `Option` is +there because `pathmap` locations really do come in three states — absent, +present-without-a-value (a **dangling path**), and valued — and `create_path`, +`remove_val(false)` and a long list of operation-specific leaks all produce the +middle one. + +Modelling the middle state is necessary to specify those operations, but it is +also where nearly all of the specification's difficulty lives. Half of +`FINDINGS.md` is about it, `subtract` needs a special rule for "where the source +has no node at all, keep `self`'s subtree verbatim, dangling paths included", +and every algebraic operation has to say which valueless locations survive it. + +This model takes the other branch. It covers **only the subset of the API that +cannot produce a dangling path**, and in exchange it has no `Option`: + + entries : List (Path × V) + +A location exists iff some key has it as a prefix. Existence is *derived*, not +stored, so a dangling path is not merely absent from the model — it is +unrepresentable. There is no third state to specify, no prune flag to thread, +and `subtract` is pointwise. + +The claim this model makes is therefore stronger than the other one's. Where +`PathMapModel` says "here is what the crate does with dangling paths", +`PrunedModel` says "these operations never create one", and a trace divergence +is either a wrong value or a dangling path that should not be there. See +`PrunedModel/Fuzz.lean` for which operations are in the subset and why. + +## What is shared + +`PathMapModel.Basic` — `Path` and its prefix and lexicographic orders, +`ByteMask`, `ValOps`/`ValRes`, `AlgStatus` — is vocabulary rather than model, so +it is imported rather than duplicated. Everything below is independent of +`PathMapModel`. + +## Canonical form + +`entries` is sorted by `Path.lt` with no duplicate keys, so structural equality +*is* observational equality — which is what lets the model decide +`AlgebraicStatus::Identity` against `Element`. Every constructor goes through +`mk'`, which restores that form. +-/ + +namespace PrunedModel + +open PathMapModel + +/-- A `pathmap` trie with no dangling paths: a finite path→value map. + +Two things are *derived* rather than stored, and that is the whole design. + +The set of locations that exist is the prefix closure of the keys, plus the root; +`paths` computes it. So a dangling path is not merely absent from the model, it +is unrepresentable — which is what this model is for. + +Canonical form is carried in the type rather than asserted in a docstring. +`sorted` says the keys strictly increase in `Path.lt`, which by +`distinctKeys_of_sortedKeys` also rules out a key bound twice. Two consequences: +there is no junk inhabitant, so `PrunedMap` *is* the finite path→value map rather +than a representation of one; and structural equality is observational equality +(`eq_of_sortedKeys_of_lookup`), which is what lets the lattice laws in +`Lattice.lean` be equations with no side conditions. The field used to be a bare +list with a `Canonical` predicate the laws carried as a hypothesis. -/ +structure PrunedMap (V : Type) where + /-- Every location that carries a value, with it, in depth-first order. -/ + entries : List (Path × V) + /-- Keys strictly increasing: the canonical-form invariant. -/ + sorted : SortedKeys entries + +namespace PrunedMap + +variable {V : Type} + +/-! ## Construction + +`normVals` and its lemmas live in `PrunedModel/Canon.lean`; the only thing to do +here is carry the proof it supplies. -/ + +/-- Build a map from a raw, possibly unsorted, possibly duplicate-keyed +association list. + +This is the *only* constructor, and it takes no path argument: there is nothing +to say about which locations exist, because the keys already say it. The proof +field comes from `sortedKeys_normVals` — canonicalisation is what establishes the +invariant, so every map in the model is canonical by construction. -/ +def mk' (vals : List (Path × V)) : PrunedMap V := ⟨normVals vals, sortedKeys_normVals vals⟩ + +/-- The empty trie. Its root still exists — `PathMap::new().read_zipper()` +reports `path_exists() == true` — but nothing else does. -/ +def empty : PrunedMap V := ⟨[], trivial⟩ + +/-- **Equality is observational.** Two tries holding the same value at every path +are the same trie: the entry lists are sorted, so each is the unique sorted +enumeration of its own contents, and the `sorted` fields are proofs of a `Prop` +and so equal automatically. + +This is why `Lattice.lean` can state the lattice laws as `=`. -/ +theorem ext {a b : PrunedMap V} (h : ∀ k, a.entries.lookup k = b.entries.lookup k) : a = b := by + cases a; cases b + cases eq_of_sortedKeys_of_lookup _ _ ‹SortedKeys _› ‹SortedKeys _› h + rfl + +/-- Printed as its entry list: the `sorted` field is a `Prop` and carries no +information, so `deriving Repr` cannot be used and there is nothing to lose. -/ +instance [Repr V] : Repr (PrunedMap V) where + reprPrec t n := reprPrec t.entries n + +instance : Inhabited (PrunedMap V) := ⟨empty⟩ + +/-! ## Observations + +These functions are the entire observable interface of a trie; every +specification in this model is phrased in terms of them. -/ + +/-- The valued locations, in depth-first order. -/ +def keys (t : PrunedMap V) : List Path := t.entries.map (·.1) + +/-- Every location that carries a value, with it. (`entries` under its +`PathMapModel` name, kept so the two models read alike.) -/ +def vals (t : PrunedMap V) : List (Path × V) := t.entries + +/-- `Zipper::val` / `PathMap::get_val_at`: the value at `p`, if any. -/ +def valAt (t : PrunedMap V) (p : Path) : Option V := t.entries.lookup p + +/-- `Zipper::path_exists`. + +A location exists iff it is the root or some key has it as a prefix. This is +the whole content of the model's claim: there is no way to exist *without* +leading to a value. -/ +def pathExists (t : PrunedMap V) (p : Path) : Bool := + p.isEmpty || t.keys.any (fun k => p ≼ k) + +/-- Every location that exists, in depth-first order: the prefix closure of the +keys, with the root. -/ +def paths (t : PrunedMap V) : List Path := + Path.sortDedup (([] : Path) :: t.keys.flatMap Path.prefixes) + +/-- `Zipper::child_mask`: the bytes `b` for which `p ++ [b]` exists. + +Read straight off the keys — a child exists iff some key goes through it — which +is the simplification the missing `Option` buys. -/ +def childMask (t : PrunedMap V) (p : Path) : ByteMask := + ByteMask.ofList <| t.keys.filterMap fun k => + match Path.stripPrefix p k with + | some (b :: _) => some b + | _ => none + +/-- `Zipper::child_count`. -/ +def childCount (t : PrunedMap V) (p : Path) : Nat := (t.childMask p).length + +/-- `ZipperMoving::val_count`: values at and below `p`. -/ +def valCount (t : PrunedMap V) (p : Path) : Nat := + (t.entries.filter (fun kv => p ≼ kv.1)).length + +/-- `TrieNode::node_is_empty` applied to the node *below* `p`: no descendants. -/ +def belowIsEmpty (t : PrunedMap V) (p : Path) : Bool := + t.keys.all (fun k => !(p ≼ k) || k == p) + +/-- `PathMap::is_empty`. With no dangling paths this is just "no values". -/ +def isEmptyMap (t : PrunedMap V) : Bool := t.entries.isEmpty + +/-! ## Sub-tries and grafting -/ + +/-- The subtrie rooted at `p`, **including** the value at `p` as its root value: +`make_map` / `take_map` under the default `graft_root_vals` feature, and what a +zipper rooted at `p` sees. -/ +def subtrie (t : PrunedMap V) (p : Path) : PrunedMap V := + mk' (t.entries.filterMap fun kv => (Path.stripPrefix p kv.1).map (·, kv.2)) + +/-- Remove everything at and below `p`. -/ +def removeAt (t : PrunedMap V) (p : Path) : PrunedMap V := + mk' (t.entries.filter (fun kv => !(p ≼ kv.1))) + +/-- Remove everything strictly below `p`; the value at `p` survives. -/ +def removeBelow (t : PrunedMap V) (p : Path) : PrunedMap V := + mk' (t.entries.filter (fun kv => !(p ≼ kv.1) || kv.1 == p)) + +/-- Replace everything strictly below `p` with the strictly-below part of `s`. + +The value at `p` is not touched: `graft_internal` only ever replaces a node, and +the value at a location lives in its parent's cell. Grafting an empty node here +*removes* the location, where `PathMapModel.graftBelow` leaves it dangling — +that difference is the model's main claim about `graft`, and `Fuzz.lean` says +what the crate does with it. -/ +def graftBelow (t : PrunedMap V) (p : Path) (s : PrunedMap V) : PrunedMap V := + mk' ((t.removeBelow p).entries ++ s.entries.filterMap + (fun kv => if kv.1.isEmpty then none else some (p ++ kv.1, kv.2))) + +/-! ## Point updates -/ + +/-- `ZipperWriting::set_val` / `PathMap::set_val_at`. Returns the replaced value. -/ +def setVal (t : PrunedMap V) (p : Path) (v : V) : Option V × PrunedMap V := + (t.valAt p, mk' ((p, v) :: t.entries.filter (fun kv => !(kv.1 == p)))) + +/-- `ZipperWriting::remove_val`. + +In this model removal is *inherently* pruning: the chain that led to the value +stops existing the moment the value does, because existence is derived from the +keys. There is no prune flag, and the crate's `remove_val(true)` is what this +specifies. -/ +def removeVal (t : PrunedMap V) (p : Path) : Option V × PrunedMap V := + (t.valAt p, mk' (t.entries.filter (fun kv => !(kv.1 == p)))) + +/-! ## Pruning + +`prune_path` deletes the dangling chain ending at the focus. Here there is +never one: see `Spec.no_dangling_tip`. The operation is kept in the model and in +the fuzzer's table precisely so that the crate's `0` can be checked against it — +a non-zero prune on a trie built only from this subset means something in the +subset leaked a dangling path. -/ + +/-- `ZipperWriting::prune_path`: always a no-op, always `0` bytes. -/ +def prunePath (t : PrunedMap V) (_p : Path) : Nat × PrunedMap V := (0, t) + +/-! ## Algebraic operations + +Pointwise, all of them. `PathMapModel` needs a rule per operation for which +valueless locations survive — and `subtract` needs two, because `psubtract_dyn` +short-circuits on an absent child and keeps `self`'s dangling paths there. With +no dangling paths to keep, "keep `self`'s subtree verbatim where the source has +no node" and "subtract pointwise" coincide, so the rules collapse. -/ + +variable (ops : ValOps V) + +/-- `Option::pjoin` from `src/ring.rs`. -/ +def joinVal : Option V → Option V → Option V + | none, b => b + | some a, none => some a + | some a, some b => (ops.pjoin a b).resolve a b + +/-- `Option::pmeet`: a value survives only where *both* sides have one. -/ +def meetVal : Option V → Option V → Option V + | some a, some b => (ops.pmeet a b).resolve a b + | _, _ => none + +/-- `Option::psubtract`. -/ +def subVal : Option V → Option V → Option V + | none, _ => none + | some a, none => some a + | some a, some b => (ops.psub a b).resolve a b + +/-- Join (union). -/ +def join (a b : PrunedMap V) : PrunedMap V := + mk' <| (Path.sortDedup (a.keys ++ b.keys)).filterMap fun k => + (joinVal ops (a.valAt k) (b.valAt k)).map (k, ·) + +/-- Meet (intersection). -/ +def meet (a b : PrunedMap V) : PrunedMap V := + mk' <| a.keys.filterMap fun k => (meetVal ops (a.valAt k) (b.valAt k)).map (k, ·) + +/-- Subtract. -/ +def sub (a b : PrunedMap V) : PrunedMap V := + mk' <| a.entries.filterMap fun kv => + (subVal ops (some kv.2) (b.valAt kv.1)).map (kv.1, ·) + +/-- Is `q` *validated* by `b` — does some non-empty prefix of `q` carry a value +in `b`? + +The node-level reading of `prestrict`: a node has no root value, so the empty +prefix never validates. -/ +def validatedBy (b : PrunedMap V) (q : Path) : Bool := + (List.range q.length).any fun i => (b.valAt (q.take (i + 1))).isSome + +/-- `prestrict` at node level: keep the values of `a` validated by `b`. Once a +location is validated, everything below it is kept. -/ +def restrictBelowRoot (a b : PrunedMap V) : PrunedMap V := + mk' (a.entries.filter (fun kv => validatedBy b kv.1)) + +/-- Structural — hence observational — equality. Decides +`AlgebraicStatus::Identity`, which `pathmap` reports exactly when the output +equals `self`. -/ +def beqT (ops : ValOps V) (a b : PrunedMap V) : Bool := + a.entries.length == b.entries.length && + (a.entries.zip b.entries).all fun xy => xy.1.1 == xy.2.1 && ops.beq xy.1.2 xy.2.2 + +/-! ## Path surgery -/ + +/-- `ZipperWriting::insert_prefix` at map level: put `k` in front of every path, +the root's included. -/ +def prepend (t : PrunedMap V) (k : Path) : PrunedMap V := + mk' (t.entries.map fun kv => (k ++ kv.1, kv.2)) + +/-- The existing locations exactly `k` bytes below the root, depth-first. + +Locations, not keys: `descend_first_k_path` stops at any location at that depth, +whether or not it carries a value. -/ +def kPaths (t : PrunedMap V) (k : Nat) : List Path := + t.paths.filter (fun q => q.length == k) + +/-- `drop_head` / `join_k_path_into`: strip the first `k` bytes from every path +and join the resulting subtries, root values included — so a value at depth +exactly `k` becomes a root value, and values above depth `k` are dropped. -/ +def dropHead (t : PrunedMap V) (k : Nat) : PrunedMap V := + if k == 0 then t + else (t.kPaths k).foldl (fun acc q => join ops acc (t.subtrie q)) empty + +end PrunedMap +end PrunedModel diff --git a/lean/PrunedModel/Nested.lean b/lean/PrunedModel/Nested.lean new file mode 100644 index 00000000..2a88b64f --- /dev/null +++ b/lean/PrunedModel/Nested.lean @@ -0,0 +1,169 @@ +import PrunedModel.Lattice + +/-! +# A trie can be a value + +`IsLatticeVals` is a condition on a *value* type, and `PrunedMap V` has `join`, +`meet` and `sub` of its own — so can a trie be the value type of another trie? +Does the lattice structure compose? + +It does, and the shortness of this file is the point. When the entry list was a +bare `List (Path × V)` the answer was *no*: the type admitted +`⟨[([0], 1), ([0], 2)]⟩`, a list binding one key twice, and `join` of it with +itself kept only the first binding, so `join a a = a` was false for it. Five of +the ten laws failed, and they were exactly the five whose right-hand side is an +operand rather than another operation's output — the ones that needed a +`Canonical` hypothesis. Nesting then required a subtype of canonical tries, with +the lattice structure lifted through it by hand. + +Carrying sortedness in `PrunedMap`'s type removed the inhabitant. There is now +nothing to exclude: the expression above does not typecheck, because +`SortedKeys [([0], 1), ([0], 2)]` is false. So `PrunedMap V` is itself a lattice +value type, the subtype is gone, and this file is the ten-line lift. + +One law still needs more than the `Lattice.lean` §3 bundle, and that has nothing +to do with canonicity. `joinDistribMeet` has a single case reducing to +`meet (join a b) a = a` — absorption with the join on the *left*. A commutative +lattice gets it from the standard axiom read backwards; `pathmap`'s join is not +commutative, so the two orientations are different statements and only one is an +axiom. It is `IsFlipAbsorb`, and both instances satisfy it. +-/ + +namespace PrunedModel + +open PathMapModel PrunedMap + +variable {V : Type} {ops : ValOps V} + +/-! ## Tries as a value type -/ + +/-- `PrunedMap V` as a `ValOps`: `pjoin` is `join`, and so on. Each reports +`Element`, the result being a new trie rather than one of the operands. -/ +def trieOps (ops : ValOps V) : ValOps (PrunedMap V) where + pjoin a b := .elem (join ops a b) + pmeet a b := .elem (meet ops a b) + psub a b := .elem (sub ops a b) + beq a b := beqT ops a b + +@[simp] theorem joinVal_trieOps (a b : PrunedMap V) : + joinVal (trieOps ops) (some a) (some b) = some (join ops a b) := rfl + +@[simp] theorem meetVal_trieOps (a b : PrunedMap V) : + meetVal (trieOps ops) (some a) (some b) = some (meet ops a b) := rfl + +/-- **Tries are a lattice value type.** All ten laws, no side conditions: every +case is either a `rfl` on `Option` or a §7 equation applied directly. -/ +theorem trieOps_isLattice (h : IsLatticeVals ops) (hf : IsFlipAbsorb ops) : + IsLatticeVals (trieOps ops) where + joinAssoc x y z := by + match x, y, z with + | none, _, _ => rfl + | some _, none, _ => rfl + | some _, some _, none => rfl + | some a, some b, some c => exact congrArg some (join_assoc_eq h a b c) + meetAssoc x y z := by + match x, y, z with + | none, _, _ => rfl + | some _, none, _ => rfl + | some _, some _, none => rfl + | some a, some b, some c => exact congrArg some (meet_assoc_eq h a b c) + joinIdem x := by + match x with + | none => rfl + | some a => exact congrArg some (join_idem_eq h a) + meetIdem x := by + match x with + | none => rfl + | some a => exact congrArg some (meet_idem_eq h a) + joinNone x := by cases x <;> rfl + meetNone x := by cases x <;> rfl + absorbMeetJoin x y := by + match x, y with + | none, _ => rfl + | some a, none => exact congrArg some (meet_idem_eq h a) + | some a, some b => exact congrArg some (absorb_meet_join_eq h a b) + absorbJoinMeet x y := by + match x, y with + | none, _ => rfl + | some _, none => rfl + | some a, some b => exact congrArg some (absorb_join_meet_eq h a b) + meetDistribJoin x y z := by + match x, y, z with + | none, _, _ => rfl + | some _, none, none => rfl + | some _, none, some _ => rfl + | some _, some _, none => rfl + | some a, some b, some c => exact congrArg some (meet_distrib_join_eq h a b c) + joinDistribMeet x y z := by + match x, y, z with + | none, _, _ => rfl + | some a, none, none => exact congrArg some (meet_idem_eq h a).symm + | some a, none, some c => exact congrArg some (absorb_meet_join_eq h a c).symm + -- the one case a commutative lattice would get for free + | some a, some b, none => exact congrArg some (absorb_meet_join_flip_eq hf a b).symm + | some a, some b, some c => exact congrArg some (join_distrib_meet_eq h a b c) + +/-- …and a commutative one when the values under them are. -/ +theorem trieOps_isComm (hc : IsCommVals ops) : IsCommVals (trieOps ops) where + joinComm x y := by + match x, y with + | none, none => rfl + | none, some _ => rfl + | some _, none => rfl + | some a, some b => exact congrArg some (join_comm_eq hc a b) + meetComm x y := by + match x, y with + | none, none => rfl + | none, some _ => rfl + | some _, none => rfl + | some a, some b => exact congrArg some (meet_comm_eq hc a b) + +/-- The mirrored absorption lifts too, so the construction iterates. -/ +theorem trieOps_isFlipAbsorb (h : IsLatticeVals ops) (hf : IsFlipAbsorb ops) : + IsFlipAbsorb (trieOps ops) where + absorbMeetJoinFlip x y := by + match x, y with + | none, none => rfl + | none, some _ => rfl + | some a, none => exact congrArg some (meet_idem_eq h a) + | some a, some b => exact congrArg some (absorb_meet_join_flip_eq hf a b) + +/-! ## So tries nest, to any depth + +`PrunedMap (PrunedMap Unit)` — a trie whose values are sets of paths — is a +distributive lattice with a least element, commutative. `PrunedMap (PrunedMap +UInt64)` is the same minus commutativity. And `trieOps` of either is again a +lattice value type, so it iterates. -/ + +theorem nested_unit_isLattice : IsLatticeVals (trieOps unitOps) := + trieOps_isLattice unit_isLattice unit_isFlipAbsorb +theorem nested_unit_isComm : IsCommVals (trieOps unitOps) := trieOps_isComm unit_isComm +theorem nested_unit_isFlipAbsorb : IsFlipAbsorb (trieOps unitOps) := + trieOps_isFlipAbsorb unit_isLattice unit_isFlipAbsorb +theorem nested_u64_isLattice : IsLatticeVals (trieOps u64Ops) := + trieOps_isLattice u64_isLattice u64_isFlipAbsorb +theorem nested_u64_isFlipAbsorb : IsFlipAbsorb (trieOps u64Ops) := + trieOps_isFlipAbsorb u64_isLattice u64_isFlipAbsorb + +example (a b c : PrunedMap (PrunedMap Unit)) : + join (trieOps unitOps) (join (trieOps unitOps) a b) c + = join (trieOps unitOps) a (join (trieOps unitOps) b c) := + join_assoc_eq nested_unit_isLattice a b c + +example (a b : PrunedMap (PrunedMap Unit)) : + meet (trieOps unitOps) a b = meet (trieOps unitOps) b a := + meet_comm_eq nested_unit_isComm a b + +example (a b c : PrunedMap (PrunedMap UInt64)) : + meet (trieOps u64Ops) a (join (trieOps u64Ops) b c) + = join (trieOps u64Ops) (meet (trieOps u64Ops) a b) (meet (trieOps u64Ops) a c) := + meet_distrib_join_eq nested_u64_isLattice a b c + +-- Three deep, to show the iteration is real rather than a figure of speech. +example (a b c : PrunedMap (PrunedMap (PrunedMap Unit))) : + join (trieOps (trieOps unitOps)) a (meet (trieOps (trieOps unitOps)) b c) + = meet (trieOps (trieOps unitOps)) + (join (trieOps (trieOps unitOps)) a b) (join (trieOps (trieOps unitOps)) a c) := + join_distrib_meet_eq (trieOps_isLattice nested_unit_isLattice nested_unit_isFlipAbsorb) a b c + +end PrunedModel diff --git a/lean/PrunedModel/Pointwise.lean b/lean/PrunedModel/Pointwise.lean new file mode 100644 index 00000000..49c87e25 --- /dev/null +++ b/lean/PrunedModel/Pointwise.lean @@ -0,0 +1,331 @@ +import PrunedModel.Lattice + +/-! +# Every map operation, read at a single path + +`Lattice.lean` shows that `join` and `meet` are pointwise on `valAt`. This file +does the same for the rest of `Map.lean` — the operations the write zipper is +built from: `subtrie`, `removeAt`, `removeBelow`, `graftBelow`, `setVal`, +`removeVal`, `sub`, `restrictBelowRoot` and `prepend`. + +Each lemma says what the result holds at an arbitrary path `k`, in terms of what +the arguments hold. With `PrunedMap.ext` that is a complete description of the +result, so `Zippy.lean` never has to look inside an entry list. + +Nothing here is specific to `()`: the lemmas hold for every value type. +-/ + +namespace PrunedModel + +open PathMapModel + +/-! ## Prefixes -/ + +theorem Path.isPrefixOf_iff : ∀ (p q : Path), Path.isPrefixOf p q = true ↔ ∃ r, q = p ++ r + | [], q => by simp [Path.isPrefixOf] + | a :: as, [] => by simp [Path.isPrefixOf] + | a :: as, b :: bs => by + simp only [Path.isPrefixOf, Bool.and_eq_true, beq_iff_eq, Path.isPrefixOf_iff as bs, + List.cons_append, List.cons.injEq] + constructor + · rintro ⟨rfl, r, rfl⟩; exact ⟨r, rfl, rfl⟩ + · rintro ⟨r, rfl, rfl⟩; exact ⟨rfl, r, rfl⟩ + +theorem Path.stripPrefix_eq_some : ∀ (p q r : Path), Path.stripPrefix p q = some r ↔ q = p ++ r + | [], q, r => by simp [Path.stripPrefix] + | a :: as, [], r => by simp [Path.stripPrefix] + | a :: as, b :: bs, r => by + simp only [Path.stripPrefix, List.cons_append, List.cons.injEq] + by_cases h : a = b + · subst h; simp [Path.stripPrefix_eq_some as bs r] + · simp [h, Ne.symm h] + +theorem Path.stripPrefix_append (p r : Path) : Path.stripPrefix p (p ++ r) = some r := + (Path.stripPrefix_eq_some p _ r).mpr rfl + +theorem Path.stripPrefix_eq_none (p q : Path) : + Path.stripPrefix p q = none ↔ ∀ r, q ≠ p ++ r := by + constructor + · intro h r hq; rw [hq, Path.stripPrefix_append] at h; cases h + · intro h + cases hs : Path.stripPrefix p q with + | none => rfl + | some r => exact absurd ((Path.stripPrefix_eq_some p q r).mp hs) (h r) + +theorem Path.isPrefixOf_eq_isSome_stripPrefix (p q : Path) : + Path.isPrefixOf p q = (Path.stripPrefix p q).isSome := by + cases hs : Path.stripPrefix p q with + | some r => + simp only [Option.isSome_some] + exact (Path.isPrefixOf_iff p q).mpr ⟨r, (Path.stripPrefix_eq_some p q r).mp hs⟩ + | none => + simp only [Option.isSome_none] + cases hp : Path.isPrefixOf p q with + | false => rfl + | true => + obtain ⟨r, hr⟩ := (Path.isPrefixOf_iff p q).mp hp + exact absurd hr ((Path.stripPrefix_eq_none p q).mp hs r) + +/-! ## `lookup` through list surgery -/ + +variable {V : Type} + +/-- `List.lookup` on a cons, as an `if` on `Prop` equality. -/ +theorem lookup_cons' (k : Path) (kv : Path × V) (es : List (Path × V)) : + es.lookup k = es.lookup k ∧ + (kv :: es).lookup k = if k = kv.1 then some kv.2 else es.lookup k := by + refine ⟨rfl, ?_⟩ + obtain ⟨k1, v⟩ := kv + by_cases h : k = k1 + · subst h; simp [List.lookup] + · have : (k == k1) = false := by simp [h] + simp [List.lookup, this, h] + +theorem lookup_cons_if (k : Path) (kv : Path × V) (es : List (Path × V)) : + (kv :: es).lookup k = if k = kv.1 then some kv.2 else es.lookup k := + (lookup_cons' k kv es).2 + +theorem lookup_append (l₁ l₂ : List (Path × V)) (k : Path) : + (l₁ ++ l₂).lookup k = ((l₁.lookup k).or (l₂.lookup k)) := by + induction l₁ with + | nil => simp + | cons kv rest ih => + rw [List.cons_append, lookup_cons_if, lookup_cons_if, ih] + split <;> simp + +/-- Filtering on keys alone filters lookups the same way. -/ +theorem lookup_filter_key (f : Path → Bool) (l : List (Path × V)) (k : Path) : + (l.filter (fun kv => f kv.1)).lookup k = if f k then l.lookup k else none := by + induction l with + | nil => simp + | cons kv rest ih => + rw [List.filter_cons, lookup_cons_if] + by_cases hk : k = kv.1 + · subst hk; cases hf : f kv.1 <;> simp [hf, lookup_cons_if, ih] + · by_cases hf : f kv.1 = true <;> simp [hf, ih, lookup_cons_if, hk] + +/-- Re-keying every entry by stripping `p` looks up `p ++ k`. -/ +theorem lookup_filterMap_strip (p : Path) (l : List (Path × V)) (k : Path) : + (l.filterMap fun kv => (Path.stripPrefix p kv.1).map (·, kv.2)).lookup k = l.lookup (p ++ k) := by + induction l with + | nil => simp + | cons kv rest ih => + rw [List.filterMap_cons, lookup_cons_if] + cases hs : Path.stripPrefix p kv.1 with + | none => + have hne : p ++ k ≠ kv.1 := fun h => (Path.stripPrefix_eq_none p kv.1).mp hs k h.symm + simp [ih, hne] + | some r => + have hk := (Path.stripPrefix_eq_some p kv.1 r).mp hs + simp only [Option.map_some, lookup_cons_if, ih, hk, List.append_cancel_left_eq] + +/-- Prefixing every key with `p` looks up the stripped path. -/ +theorem lookup_map_prepend (p : Path) (l : List (Path × V)) (k : Path) : + (l.map fun kv => (p ++ kv.1, kv.2)).lookup k = + match Path.stripPrefix p k with + | some r => l.lookup r + | none => none := by + induction l with + | nil => cases Path.stripPrefix p k <;> rfl + | cons kv rest ih => + rw [List.map_cons, lookup_cons_if, ih] + cases hs : Path.stripPrefix p k with + | none => + have : k ≠ p ++ kv.1 := (Path.stripPrefix_eq_none p k).mp hs kv.1 + simp [this] + | some r => + have hk := (Path.stripPrefix_eq_some p k r).mp hs + subst hk + simp [lookup_cons_if] + +/-- A comprehension that keeps each key and transforms its value, over a list with +distinct keys. -/ +theorem lookup_filterMap_val (g : Path → V → Option V) : + ∀ (l : List (Path × V)), DistinctKeys l → ∀ k, + (l.filterMap fun kv => (g kv.1 kv.2).map (kv.1, ·)).lookup k = (l.lookup k).bind (g k) + | [], _, k => by simp + | kv :: rest, hd, k => by + rw [List.filterMap_cons, lookup_cons_if] + have ih := lookup_filterMap_val g rest hd.2 k + by_cases hk : k = kv.1 + · subst hk + have hnot : kv.1 ∉ rest.map (·.1) := hd.1 + have hrest : (rest.filterMap fun kv => (g kv.1 kv.2).map (kv.1, ·)).lookup kv.1 = none := by + rw [ih, lookup_eq_none_of_not_mem_keys hnot]; rfl + cases hg : g kv.1 kv.2 with + | none => simp [hrest, hg] + | some v => simp [hg] + · cases hg : g kv.1 kv.2 <;> simp [ih, lookup_cons_if, hk] + +/-- The comprehension `graftBelow` and `insertPrefixBelow` use: drop the root +entry, prefix the rest. -/ +theorem filterMap_prepend (p : Path) (l : List (Path × V)) : + l.filterMap (fun kv => if kv.1.isEmpty then none else some (p ++ kv.1, kv.2)) = + (l.filter fun kv => !kv.1.isEmpty).map (fun kv => (p ++ kv.1, kv.2)) := by + induction l with + | nil => rfl + | cons kv rest ih => + obtain ⟨k, v⟩ := kv + simp only [List.isEmpty_iff] at ih ⊢ + cases k <;> simp [ih] + +/-! ## Each map operation, at one path -/ + +namespace PrunedMap + +theorem valAt_def (t : PrunedMap V) (k : Path) : t.valAt k = t.entries.lookup k := rfl + +theorem valAt_subtrie (t : PrunedMap V) (p k : Path) : + (t.subtrie p).valAt k = t.valAt (p ++ k) := by + rw [subtrie, valAt_mk', lookup_filterMap_strip]; rfl + +theorem valAt_removeAt (t : PrunedMap V) (p k : Path) : + (t.removeAt p).valAt k = if Path.isPrefixOf p k then none else t.valAt k := by + rw [removeAt, valAt_mk', lookup_filter_key (fun k => !(Path.isPrefixOf p k))] + cases Path.isPrefixOf p k <;> rfl + +theorem valAt_removeBelow (t : PrunedMap V) (p k : Path) : + (t.removeBelow p).valAt k = + if Path.isPrefixOf p k = true ∧ k ≠ p then none else t.valAt k := by + rw [removeBelow, valAt_mk', lookup_filter_key (fun k => !(Path.isPrefixOf p k) || k == p)] + by_cases h1 : Path.isPrefixOf p k = true <;> by_cases h2 : k = p <;> simp [h1, h2] <;> rfl + +theorem valAt_setVal (t : PrunedMap V) (p : Path) (v : V) (k : Path) : + (t.setVal p v).2.valAt k = if k = p then some v else t.valAt k := by + rw [setVal, valAt_mk', lookup_cons_if, lookup_filter_key (fun k => !(k == p))] + by_cases h : k = p <;> simp [h] <;> rfl + +theorem setVal_fst (t : PrunedMap V) (p : Path) (v : V) : (t.setVal p v).1 = t.valAt p := rfl + +theorem valAt_removeVal (t : PrunedMap V) (p k : Path) : + (t.removeVal p).2.valAt k = if k = p then none else t.valAt k := by + rw [removeVal, valAt_mk', lookup_filter_key (fun k => !(k == p))] + by_cases h : k = p <;> simp [h] <;> rfl + +theorem removeVal_fst (t : PrunedMap V) (p : Path) : (t.removeVal p).2 = (t.removeVal p).2 ∧ + (t.removeVal p).1 = t.valAt p := ⟨rfl, rfl⟩ + +/-- Below `p`, the grafted map; everywhere else — `p` itself included — the old one. -/ +theorem valAt_graftBelow (t : PrunedMap V) (p : Path) (s : PrunedMap V) (k : Path) : + (t.graftBelow p s).valAt k = + match Path.stripPrefix p k with + | some (b :: r) => s.valAt (b :: r) + | _ => t.valAt k := by + rw [graftBelow, valAt_mk', lookup_append] + have hA : (t.removeBelow p).entries.lookup k = (t.removeBelow p).valAt k := rfl + rw [hA, valAt_removeBelow] + rw [filterMap_prepend, lookup_map_prepend] + cases hs : Path.stripPrefix p k with + | none => + have : ¬ (Path.isPrefixOf p k = true ∧ k ≠ p) := by + rintro ⟨h, _⟩ + rw [Path.isPrefixOf_eq_isSome_stripPrefix, hs] at h; cases h + simp [this] + | some r => + have hk := (Path.stripPrefix_eq_some p k r).mp hs + subst hk + have hpre : Path.isPrefixOf p (p ++ r) = true := (Path.isPrefixOf_iff _ _).mpr ⟨r, rfl⟩ + cases r with + | nil => dsimp only; rw [lookup_filter_key (fun k => !k.isEmpty)]; simp + | cons b r => + have hne : p ++ b :: r ≠ p := by + intro h; have := congrArg List.length h; simp at this + simp only [hpre, ne_eq, hne, not_false_eq_true, and_self, if_true, Option.none_or] + rw [lookup_filter_key (fun k => !k.isEmpty)] + rfl + +theorem valAt_sub (ops : ValOps V) (a b : PrunedMap V) (k : Path) : + (sub ops a b).valAt k = subVal ops (a.valAt k) (b.valAt k) := by + rw [sub, valAt_mk', + lookup_filterMap_val (fun k v => subVal ops (some v) (b.valAt k)) _ + (distinctKeys_of_sortedKeys a.sorted)] + show (a.valAt k).bind _ = _ + cases a.valAt k <;> rfl + +theorem valAt_restrictBelowRoot (a b : PrunedMap V) (k : Path) : + (restrictBelowRoot a b).valAt k = if validatedBy b k then a.valAt k else none := by + rw [restrictBelowRoot, valAt_mk', lookup_filter_key (fun k => validatedBy b k)]; rfl + +theorem valAt_prepend (t : PrunedMap V) (pre k : Path) : + (t.prepend pre).valAt k = + match Path.stripPrefix pre k with + | some r => t.valAt r + | none => none := by + rw [prepend, valAt_mk', lookup_map_prepend] + cases Path.stripPrefix pre k <;> rfl + +theorem isEmptyMap_iff (t : PrunedMap V) : t.isEmptyMap = true ↔ ∀ k, t.valAt k = none := by + constructor + · intro h k + have : t.entries = [] := List.isEmpty_iff.mp h + simp [valAt_def, this] + · intro h + cases he : t.entries with + | nil => simp [isEmptyMap, he] + | cons kv rest => + have := h kv.1 + rw [valAt_def, he, lookup_cons_if] at this + simp at this + +theorem eq_empty_iff (t : PrunedMap V) : t = empty ↔ ∀ k, t.valAt k = none := by + constructor + · rintro rfl k; rfl + · intro h; exact ext fun k => (h k).trans rfl + +theorem belowIsEmpty_iff (t : PrunedMap V) (p : Path) : + t.belowIsEmpty p = true ↔ ∀ b r, t.valAt (p ++ b :: r) = none := by + rw [belowIsEmpty, keys, List.all_map] + simp only [List.all_eq_true, Function.comp, Bool.or_eq_true, Bool.not_eq_true', beq_iff_eq] + constructor + · intro h b r + cases hv : t.valAt (p ++ b :: r) with + | none => rfl + | some v => + exfalso + obtain ⟨kv, hmem, hkv⟩ := List.lookup_isSome_iff.mp (show (t.entries.lookup (p ++ b :: r)).isSome by + rw [← valAt_def, hv]; rfl) + have hk : kv.1 = p ++ b :: r := (eq_of_beq hkv).symm + rcases h kv hmem with h1 | h1 + · rw [hk] at h1 + have : Path.isPrefixOf p (p ++ b :: r) = true := (Path.isPrefixOf_iff _ _).mpr ⟨_, rfl⟩ + rw [this] at h1; cases h1 + · rw [hk] at h1 + have := congrArg List.length h1; simp at this + · intro h kv hmem + cases hp : Path.isPrefixOf p kv.1 with + | false => exact Or.inl rfl + | true => + right + obtain ⟨r, hr⟩ := (Path.isPrefixOf_iff _ _).mp hp + cases r with + | nil => simpa using hr + | cons b r => + exfalso + have h1 := h b r + have h2 : (t.entries.lookup kv.1).isSome := + lookup_isSome_of_mem_keys (List.mem_map.mpr ⟨kv, hmem, rfl⟩) + rw [← valAt_def, hr, h1] at h2; cases h2 + +theorem validatedBy_iff (b : PrunedMap V) (q : Path) : + validatedBy b q = true ↔ ∃ r s, r ≠ [] ∧ q = r ++ s ∧ (b.valAt r).isSome := by + rw [validatedBy, List.any_eq_true] + constructor + · rintro ⟨i, hi, hv⟩ + have hi' : i < q.length := List.mem_range.mp hi + refine ⟨q.take (i + 1), q.drop (i + 1), ?_, (List.take_append_drop _ _).symm, hv⟩ + intro h + rcases List.take_eq_nil_iff.mp h with h | h + · omega + · simp [h] at hi' + · rintro ⟨r, s, hr, rfl, hv⟩ + cases r with + | nil => exact absurd rfl hr + | cons c r => + refine ⟨r.length, List.mem_range.mpr (by simp; omega), ?_⟩ + have : ((c :: r) ++ s).take (r.length + 1) = c :: r := by + simp + rw [this]; exact hv + +end PrunedMap + +end PrunedModel diff --git a/lean/PrunedModel/Project.lean b/lean/PrunedModel/Project.lean new file mode 100644 index 00000000..6b972194 --- /dev/null +++ b/lean/PrunedModel/Project.lean @@ -0,0 +1,1479 @@ +import PathMapModel +import PrunedModel.Refine + +/-! +# Projecting `PathMapModel` onto `PrunedModel` + +`PathMapModel` records every location of a trie, valued or not; `PrunedModel` +records only the values. The projection + + π t := PrunedMap.mk' t.vals + +forgets the dangling paths and keeps everything else, and `valAt_proj` says it +loses nothing a value lookup can see — for **every** `PathMapModel.PathMap`, with +no well-formedness hypothesis, because `vals` is itself read through `valAt`. + +The theorems here say that the two models agree once dangling paths are +forgotten: for an operation `f`, + + π (f_PathMapModel x …) = f_PrunedModel (π x) … + +**Map level (§2).** Every map operation commutes with `π`: `subtrie`, +`removeAt`, `removeBelow`, `graftBelow`, `setVal`, `removeVal`, `addPath` +(`create_path`), `join`, `meet`, `sub`, `restrictBelowRoot`, the prefix shift +`insert_prefix` grafts (`PM.shift`), and `prunePath`. The last needs the trie's +locations to be prefix-closed, which every trie `mk'` builds is +(`prefixClosed_mk'`): what `prune_path` deletes is a chain that leads to no +value, and only prefix-closure lets one argue that. + +**Zipper level (§3).** For a zipper `z`, `πz z` projects its trie and keeps the +cursor. These write operations commute with it, for every value type whose +`beq` is sound and whatever the `prune` flag: + + set_val, remove_val, create_path, graft, graft_map, graft_src_at, + remove_branches, take_map (the trie it leaves), remove_prefix, join_into, + join_map_into, meet_2, restrict + +and these on a zipper whose trie is prefix-closed — every trie an operation +returns, and every trie built from `mk'`: + + prune_path, insert_prefix, meet_into, subtract_into + +`meet_into` and `subtract_into` end with `prune_path` when `prune` is set, which +may run on the trie as it was; `insert_prefix` asks whether the focus *exists*, +which `PathMapModel` answers from locations and the pruned model from values. +The read side is immediate: `val`, `val_at` and `make_map` commute by +`valAt_proj` and `proj_subtrie`. + +**Where it fails (§4).** Some operations *observe* dangling paths, and for +those the projection cannot commute; each failure is a theorem about a concrete +trie, checked by `decide`: + +* `child_mask` (hence `child_count`, `Head`, `TailsIntersection`, `Iter`) counts + dangling children; +* `restricting` decides "is there anything below the source's focus" by + locations, so a source whose node is dangling-only *erases* the destination's + values, where the pruned model leaves them alone; +* `meet_k_path_into` meets the subtrie at every location `k` bytes down, so a + dangling one is an empty operand that empties the meet — `PRUNED_FINDINGS.md` + #6, here as a theorem about the two specifications; +* `take_map` returns `some` of a value-less map for a dangling-only focus, where + the pruned model returns `none` (the trie it leaves behind still agrees). + +Not covered either way: `join_k_path_into` (its fold runs in `paths` order, +which only a canonical trie fixes, and for a non-commutative value type the +order matters), `remove_subtrie`, `graft_masked_branches`, `graft_child_maps`, +`remove_unmasked_branches`, `join_into_take`, and `prune_ascend`, whose cursor +moves by the number of dangling bytes it removed — so its *trie* projects, but +its cursor cannot. + +Statuses are not values and are not compared here. +-/ + +namespace PrunedModel +namespace Project + +open PathMapModel + +variable {V : Type} + +/-! ## 1. `PathMapModel` lookups -/ + +theorem insertValSorted_eq (kv : Path × V) : ∀ l, + PathMap.insertValSorted kv l = PrunedModel.insertValSorted kv l + | [] => rfl + | kv' :: rest => by + simp only [PathMap.insertValSorted, PrunedModel.insertValSorted, insertValSorted_eq kv rest] + +/-- The two models canonicalise values with the same function. -/ +theorem normVals_eq (l : List (Path × V)) : PathMap.normVals l = PrunedModel.normVals l := by + unfold PathMap.normVals PrunedModel.normVals + have : PathMap.dedupVals l = PrunedModel.dedupVals l := rfl + rw [this]; simp only [insertValSorted_eq] + +theorem lookup_map_self (g : Path → Option V) : + ∀ (l : List Path) (k : Path), + (l.map fun p => (p, g p)).lookup k = if k ∈ l then some (g k) else none + | [], k => by simp + | p :: rest, k => by + rw [List.map_cons, lookup_cons_if, lookup_map_self g rest k] + by_cases h : k = p + · subst h; simp + · simp [h] + +theorem valAt_eq_lookup (t : PathMap V) (k : Path) : t.valAt k = (t.entries.lookup k).bind id := by + unfold PathMap.valAt PathMap.entryAt + cases t.entries.lookup k with + | none => rfl + | some o => cases o <;> rfl + +theorem mem_prefixes_self (k : Path) : k ∈ Path.prefixes k := by + unfold Path.prefixes + exact List.mem_map.mpr ⟨k.length, List.mem_range.mpr (by omega), List.take_length⟩ + +/-- `PathMapModel.mk'` holds exactly the values it was given. -/ +theorem valAt_mk' (vs : List (Path × V)) (ps : List Path) (k : Path) : + (PathMap.mk' vs ps).valAt k = vs.lookup k := by + rw [valAt_eq_lookup] + unfold PathMap.mk' + simp only + rw [lookup_map_self] + rw [normVals_eq, ← lookup_normVals vs k] + split + · rfl + · next hk => + cases h : (PrunedModel.normVals vs).lookup k with + | none => rfl + | some v => + exfalso; apply hk + have hkey := mem_keys_of_lookup_isSome (l := PrunedModel.normVals vs) (p := k) (by rw [h]; rfl) + rw [Path.mem_sortDedup, List.mem_flatMap] + exact ⟨k, List.mem_cons_of_mem _ (List.mem_append_right _ hkey), mem_prefixes_self k⟩ + +/-- `vals` is read through `valAt`, so the two never disagree — for any trie. -/ +theorem lookup_vals (t : PathMap V) (k : Path) : t.vals.lookup k = t.valAt k := by + have h := lookup_filterMap_self (fun p => (t.entryAt p).val) t.paths k + have e : t.vals = t.paths.filterMap fun x => ((fun p => (t.entryAt p).val) x).map (Prod.mk x) := rfl + rw [e, h] + split + · rfl + · next hk => + rw [valAt_eq_lookup, lookup_eq_none_of_not_mem_keys hk]; rfl + +theorem mem_vals_lookup (t : PathMap V) {kv : Path × V} (h : kv ∈ t.vals) : + t.vals.lookup kv.1 = some kv.2 := by + rw [lookup_vals] + unfold PathMap.vals at h + obtain ⟨p, _, hp⟩ := List.mem_filterMap.mp h + cases hv : (t.entryAt p).val with + | none => rw [hv] at hp; cases hp + | some v => + rw [hv] at hp; cases hp; exact hv + +theorem valAt_isSome_mem_paths (t : PathMap V) {k : Path} (h : (t.valAt k).isSome = true) : + k ∈ t.paths := by + rw [valAt_eq_lookup] at h + cases hl : t.entries.lookup k with + | none => rw [hl] at h; cases h + | some o => exact mem_keys_of_lookup_isSome (by rw [hl]; rfl) + +theorem valAt_eq_none_of_not_mem_vals (t : PathMap V) {k : Path} (h : k ∉ t.vals.map (·.1)) : + t.valAt k = none := by + rw [← lookup_vals]; exact lookup_eq_none_of_not_mem_keys h + +/-- An association list in which equal keys carry equal values. -/ +def Functional (l : List (Path × V)) : Prop := ∀ a ∈ l, ∀ b ∈ l, a.1 = b.1 → a.2 = b.2 + +theorem mem_of_lookup : ∀ {l : List (Path × V)} {k : Path} {w : V}, + l.lookup k = some w → ∃ y ∈ l, y.1 = k ∧ y.2 = w + | [], _, _, h => by cases h + | y :: ys, k, w, h => by + rw [lookup_cons_if] at h + split at h + · next hy => cases h; exact ⟨y, List.mem_cons_self, hy.symm, rfl⟩ + · obtain ⟨z, hz, h1, h2⟩ := mem_of_lookup h + exact ⟨z, List.mem_cons_of_mem _ hz, h1, h2⟩ + +theorem functional_vals (t : PathMap V) : Functional t.vals := by + intro a ha b hb hab + have h1 := mem_vals_lookup t ha + have h2 := mem_vals_lookup t hb + rw [hab, h2] at h1 + exact (Option.some.inj h1).symm + +/-- A comprehension that keeps each key and transforms its value, over a list in +which equal keys carry equal values. -/ +theorem lookup_filterMap_val' (g : Path → V → Option V) : + ∀ (l : List (Path × V)), Functional l → ∀ k, + (l.filterMap fun kv => (g kv.1 kv.2).map (kv.1, ·)).lookup k = (l.lookup k).bind (g k) + | [], _, k => by simp + | kv :: rest, hf, k => by + have hf' : Functional rest := fun a ha b hb => hf a (List.mem_cons_of_mem _ ha) b + (List.mem_cons_of_mem _ hb) + have ih := lookup_filterMap_val' g rest hf' k + rw [List.filterMap_cons, lookup_cons_if] + by_cases hk : k = kv.1 + · subst hk + simp only [if_true, Option.bind_some] + cases hg : g kv.1 kv.2 with + | some v => simp + | none => + simp only [Option.map_none] + rw [ih] + cases hl : rest.lookup kv.1 with + | none => rfl + | some w => + obtain ⟨y, hy, h1, h2⟩ := mem_of_lookup hl + have := hf y (List.mem_cons_of_mem _ hy) kv List.mem_cons_self h1 + simp only [Option.bind_some]; rw [← h2, this, hg] + · cases g kv.1 kv.2 <;> simp [ih, lookup_cons_if, hk] + +/-! ## 2. The projection, and the map operations -/ + +/-- Forget the dangling paths. -/ +def proj (t : PathMap V) : PrunedMap V := PrunedMap.mk' t.vals + +/-- **The projection loses no value.** For every trie, canonical or not. -/ +@[simp] theorem valAt_proj (t : PathMap V) (k : Path) : (proj t).valAt k = t.valAt k := by + rw [proj, PrunedMap.valAt_mk', lookup_vals] + +/-- Two tries project to the same map exactly when they hold the same values. -/ +theorem proj_eq_proj_iff (a b : PathMap V) : proj a = proj b ↔ ∀ k, a.valAt k = b.valAt k := by + constructor + · intro h k; rw [← valAt_proj, h, valAt_proj] + · intro h; exact PrunedMap.ext fun k => by + show (proj a).valAt k = (proj b).valAt k + rw [valAt_proj, valAt_proj, h] + +theorem proj_eq_of {t : PathMap V} {M : PrunedMap V} (h : ∀ k, t.valAt k = M.valAt k) : + proj t = M := + PrunedMap.ext fun k => by + show (proj t).valAt k = M.valAt k + rw [valAt_proj, h] + +theorem filterMap_prepend' (p : Path) (l : List (Path × V)) : + l.filterMap (fun kv => if kv.1 == ([] : Path) then none else some (p ++ kv.1, kv.2)) = + (l.filter fun kv => !kv.1.isEmpty).map (fun kv => (p ++ kv.1, kv.2)) := by + induction l with + | nil => rfl + | cons kv rest ih => + obtain ⟨k, v⟩ := kv + simp only [beq_iff_eq] at ih + cases k <;> simp [ih] + +namespace PM +/-! `PathMapModel`'s operations, at one path. Each is the `PrunedModel` lemma of +the same name, reproved: the definitions are transcriptions of each other on +values, and differ only in which *locations* they keep. -/ + +theorem valAt_subtrie (t : PathMap V) (p k : Path) : (t.subtrie p).valAt k = t.valAt (p ++ k) := by + rw [PathMap.subtrie, valAt_mk', lookup_filterMap_strip, lookup_vals] + +theorem valAt_removeAt (t : PathMap V) (p k : Path) : + (t.removeAt p).valAt k = if Path.isPrefixOf p k then none else t.valAt k := by + rw [PathMap.removeAt, valAt_mk', lookup_filter_key (fun k => !(Path.isPrefixOf p k)), lookup_vals] + cases Path.isPrefixOf p k <;> rfl + +theorem valAt_removeBelow (t : PathMap V) (p k : Path) : + (t.removeBelow p).valAt k = + if Path.isPrefixOf p k = true ∧ k ≠ p then none else t.valAt k := by + rw [PathMap.removeBelow, valAt_mk', lookup_filter_key (fun k => !(Path.isPrefixOf p k) || k == p), + lookup_vals] + by_cases h1 : Path.isPrefixOf p k = true <;> by_cases h2 : k = p <;> simp [h1, h2] + +theorem valAt_setVal (t : PathMap V) (p : Path) (v : V) (k : Path) : + (t.setVal p v).2.valAt k = if k = p then some v else t.valAt k := by + rw [PathMap.setVal, valAt_mk', lookup_cons_if, lookup_filter_key (fun k => !(k == p)), lookup_vals] + by_cases h : k = p <;> simp [h] + +theorem valAt_removeVal (t : PathMap V) (p k : Path) : + (t.removeVal p).2.valAt k = if k = p then none else t.valAt k := by + rw [PathMap.removeVal, valAt_mk', lookup_filter_key (fun k => !(k == p)), lookup_vals] + by_cases h : k = p <;> simp [h] + +theorem valAt_addPath (t : PathMap V) (p k : Path) : (t.addPath p).valAt k = t.valAt k := by + rw [PathMap.addPath, valAt_mk', lookup_vals] + +theorem valAt_graftBelow (t : PathMap V) (p : Path) (s : PathMap V) (k : Path) : + (t.graftBelow p s).valAt k = + match Path.stripPrefix p k with + | some (b :: r) => s.valAt (b :: r) + | _ => t.valAt k := by + rw [PathMap.graftBelow] + rw [valAt_mk', lookup_append, lookup_vals, valAt_removeBelow, filterMap_prepend', + lookup_map_prepend] + cases hs : Path.stripPrefix p k with + | none => + have : ¬ (Path.isPrefixOf p k = true ∧ k ≠ p) := by + rintro ⟨h, _⟩ + rw [Path.isPrefixOf_eq_isSome_stripPrefix, hs] at h; cases h + simp [this] + | some r => + have hk := (Path.stripPrefix_eq_some p k r).mp hs + subst hk + have hpre : Path.isPrefixOf p (p ++ r) = true := (Path.isPrefixOf_iff _ _).mpr ⟨r, rfl⟩ + cases r with + | nil => dsimp only; rw [lookup_filter_key (fun k => !k.isEmpty)]; simp + | cons b r => + have hne : p ++ b :: r ≠ p := by + intro h; have := congrArg List.length h; simp at this + simp only [hpre, ne_eq, hne, not_false_eq_true, and_self, if_true, Option.none_or] + rw [lookup_filter_key (fun k => !k.isEmpty), lookup_vals] + rfl + +/-- What `insert_prefix` grafts: every location and value of `t`, behind `pre`. -/ +def shift (t : PathMap V) (pre : Path) : PathMap V := + PathMap.mk' (t.vals.map fun kv => (pre ++ kv.1, kv.2)) (t.paths.map fun q => pre ++ q) + +theorem valAt_shift (t : PathMap V) (pre k : Path) : + (shift t pre).valAt k = + match Path.stripPrefix pre k with + | some r => t.valAt r + | none => none := by + rw [shift, valAt_mk', lookup_map_prepend] + cases Path.stripPrefix pre k with + | none => rfl + | some r => dsimp only; rw [lookup_vals] + +theorem joinVal_eq (ops : ValOps V) (x y : Option V) : + PathMap.joinVal ops x y = PrunedMap.joinVal ops x y := by cases x <;> cases y <;> rfl +theorem meetVal_eq (ops : ValOps V) (x y : Option V) : + PathMap.meetVal ops x y = PrunedMap.meetVal ops x y := by cases x <;> cases y <;> rfl +theorem subVal_eq (ops : ValOps V) (x y : Option V) : + PathMap.subVal ops x y = PrunedMap.subVal ops x y := by cases x <;> cases y <;> rfl + +theorem valAt_join (ops : ValOps V) (a b : PathMap V) (k : Path) : + (PathMap.join ops a b).valAt k = PrunedMap.joinVal ops (a.valAt k) (b.valAt k) := by + rw [PathMap.join] + rw [valAt_mk', lookup_filterMap_self, ← joinVal_eq] + split + · rfl + · next hk => + rw [Path.mem_sortDedup, List.mem_append, not_or] at hk + rw [valAt_eq_none_of_not_mem_vals a hk.1, valAt_eq_none_of_not_mem_vals b hk.2]; rfl + +theorem valAt_meet (ops : ValOps V) (a b : PathMap V) (k : Path) : + (PathMap.meet ops a b).valAt k = PrunedMap.meetVal ops (a.valAt k) (b.valAt k) := by + rw [PathMap.meet] + rw [valAt_mk', lookup_filterMap_self, ← meetVal_eq] + split + · rfl + · next hk => + rw [Path.mem_sortDedup] at hk + rw [valAt_eq_none_of_not_mem_vals a hk]; rfl + +theorem valAt_sub (ops : ValOps V) (a b : PathMap V) (k : Path) : + (PathMap.sub ops a b).valAt k = PrunedMap.subVal ops (a.valAt k) (b.valAt k) := by + rw [PathMap.sub] + rw [valAt_mk', lookup_filterMap_val' (fun k v => PathMap.subVal ops (some v) (b.valAt k)) _ + (functional_vals a), lookup_vals, ← subVal_eq] + cases a.valAt k <;> rfl + +theorem validatedBy_eq (b : PathMap V) (q : Path) : + PathMap.validatedBy b q = PrunedMap.validatedBy (proj b) q := by + simp only [PathMap.validatedBy, PrunedMap.validatedBy, valAt_proj] + +theorem valAt_restrictBelowRoot (a b : PathMap V) (k : Path) : + (PathMap.restrictBelowRoot a b).valAt k = + if PrunedMap.validatedBy (proj b) k then a.valAt k else none := by + rw [PathMap.restrictBelowRoot, valAt_mk', lookup_filter_key (fun k => PathMap.validatedBy b k), + lookup_vals, validatedBy_eq] + +theorem valAt_removeBelow_off' {t : PathMap V} {f k : Path} (h : ∀ r, k ≠ f ++ r) : + (t.removeBelow f).valAt k = t.valAt k := by + rw [valAt_removeBelow, PZip.isPrefixOf_off h]; simp + +end PM + +/-! ### Each map operation commutes with the projection -/ + +section MapLevel +open PrunedMap (valAt_subtrie valAt_removeAt valAt_removeBelow valAt_setVal valAt_removeVal + valAt_graftBelow valAt_join valAt_meet valAt_sub valAt_restrictBelowRoot valAt_prepend) + +theorem proj_empty : proj (PathMap.empty : PathMap V) = PrunedMap.empty := + proj_eq_of fun k => by + rw [valAt_eq_lookup] + show (List.lookup k [(([] : Path), (none : Option V))]).bind id = none + rw [lookup_cons_if]; split <;> rfl + +theorem proj_subtrie (t : PathMap V) (p : Path) : proj (t.subtrie p) = (proj t).subtrie p := + proj_eq_of fun k => by rw [PM.valAt_subtrie, valAt_subtrie, valAt_proj] + +theorem proj_removeAt (t : PathMap V) (p : Path) : proj (t.removeAt p) = (proj t).removeAt p := + proj_eq_of fun k => by rw [PM.valAt_removeAt, valAt_removeAt, valAt_proj] + +theorem proj_removeBelow (t : PathMap V) (p : Path) : + proj (t.removeBelow p) = (proj t).removeBelow p := + proj_eq_of fun k => by rw [PM.valAt_removeBelow, valAt_removeBelow, valAt_proj] + +theorem proj_setVal (t : PathMap V) (p : Path) (v : V) : + (t.setVal p v).1 = ((proj t).setVal p v).1 ∧ proj (t.setVal p v).2 = ((proj t).setVal p v).2 := + ⟨by show t.valAt p = (proj t).valAt p; rw [valAt_proj], + proj_eq_of fun k => by rw [PM.valAt_setVal, valAt_setVal, valAt_proj]⟩ + +/-- `PathMapModel`'s `removeVal` leaves a dangling path; the pruned one removes the +chain. Their values agree. -/ +theorem proj_removeVal (t : PathMap V) (p : Path) : + (t.removeVal p).1 = ((proj t).removeVal p).1 ∧ + proj (t.removeVal p).2 = ((proj t).removeVal p).2 := + ⟨by show t.valAt p = (proj t).valAt p; rw [valAt_proj], + proj_eq_of fun k => by rw [PM.valAt_removeVal, valAt_removeVal, valAt_proj]⟩ + +/-- `create_path` makes a dangling path, so the projection does not see it. -/ +theorem proj_addPath (t : PathMap V) (p : Path) : proj (t.addPath p) = proj t := + proj_eq_of fun k => by rw [PM.valAt_addPath, valAt_proj] + +theorem proj_graftBelow (t : PathMap V) (p : Path) (s : PathMap V) : + proj (t.graftBelow p s) = (proj t).graftBelow p (proj s) := + proj_eq_of fun k => by + rw [PM.valAt_graftBelow, valAt_graftBelow] + cases Path.stripPrefix p k with + | none => simp + | some r => cases r <;> simp + +theorem proj_shift (t : PathMap V) (pre : Path) : proj (PM.shift t pre) = (proj t).prepend pre := + proj_eq_of fun k => by + rw [PM.valAt_shift, valAt_prepend] + cases Path.stripPrefix pre k with + | none => rfl + | some r => dsimp only; rw [valAt_proj] + +theorem proj_join (ops : ValOps V) (a b : PathMap V) : + proj (PathMap.join ops a b) = PrunedMap.join ops (proj a) (proj b) := + proj_eq_of fun k => by rw [PM.valAt_join, valAt_join, valAt_proj, valAt_proj] + +theorem proj_meet (ops : ValOps V) (a b : PathMap V) : + proj (PathMap.meet ops a b) = PrunedMap.meet ops (proj a) (proj b) := + proj_eq_of fun k => by rw [PM.valAt_meet, valAt_meet, valAt_proj, valAt_proj] + +theorem proj_sub (ops : ValOps V) (a b : PathMap V) : + proj (PathMap.sub ops a b) = PrunedMap.sub ops (proj a) (proj b) := + proj_eq_of fun k => by rw [PM.valAt_sub, valAt_sub, valAt_proj, valAt_proj] + +theorem proj_restrictBelowRoot (a b : PathMap V) : + proj (PathMap.restrictBelowRoot a b) = PrunedMap.restrictBelowRoot (proj a) (proj b) := + proj_eq_of fun k => by rw [PM.valAt_restrictBelowRoot, valAt_restrictBelowRoot, valAt_proj] + +end MapLevel + +/-! ### Pruning + +`prune_path` deletes a chain of locations ending at a dangling tip. That the +chain holds no value is the whole content of "it only removes dangling paths", +and it needs the trie's locations to be prefix-closed: otherwise a value could +sit below a location the trie does not list, and the argument that the chain +does not branch has nothing to stand on. Every trie `mk'` builds is +prefix-closed, which covers every trie an operation returns. -/ + +theorem mem_ofList (b : UInt8) (bs : List UInt8) : b ∈ ByteMask.ofList bs ↔ b ∈ bs := by + rw [ByteMask.ofList, List.mem_filterMap] + constructor + · rintro ⟨i, _, hi⟩ + simp only at hi + split at hi + · next hc => cases hi; exact List.contains_iff_mem.mp hc + · cases hi + · intro hb + refine ⟨b.toNat, List.mem_range.mpr (UInt8.toNat_lt b), ?_⟩ + simp only + rw [if_pos (by rw [UInt8.ofNat_toNat]; exact List.contains_iff_mem.mpr hb), UInt8.ofNat_toNat] + +/-- Every prefix of a location is a location. -/ +def PrefixClosed (t : PathMap V) : Prop := ∀ q ∈ t.paths, ∀ j, q.take j ∈ t.paths + +theorem prefixClosed_mk' (vs : List (Path × V)) (ps : List Path) : PrefixClosed (PathMap.mk' vs ps) := by + intro q hq j + unfold PathMap.mk' at hq ⊢ + simp only [PathMap.paths, List.map_map, Function.comp_def, List.map_id'] at hq ⊢ + rw [Path.mem_sortDedup, List.mem_flatMap] at hq ⊢ + obtain ⟨r, hr, hqr⟩ := hq + refine ⟨r, hr, ?_⟩ + unfold Path.prefixes at hqr ⊢ + obtain ⟨i, hi, rfl⟩ := List.mem_map.mp hqr + refine List.mem_map.mpr ⟨min j i, List.mem_range.mpr ?_, ?_⟩ + · have := List.mem_range.mp hi; omega + · rw [List.take_take] + +/-- Three ways two paths can sit: `p` is a prefix of `k`, `k` is a proper prefix +of `p`, or they part ways after a common prefix. -/ +theorem path_trichotomy : ∀ (p k : Path), + (∃ r, k = p ++ r) ∨ (∃ r, r ≠ [] ∧ p = k ++ r) ∨ + ∃ d x y p' k', x ≠ y ∧ p = d ++ x :: p' ∧ k = d ++ y :: k' + | [], k => Or.inl ⟨k, rfl⟩ + | a :: as, [] => Or.inr (Or.inl ⟨a :: as, by simp, rfl⟩) + | a :: as, b :: bs => by + by_cases hab : a = b + · subst hab + rcases path_trichotomy as bs with ⟨r, hr⟩ | ⟨r, hr, he⟩ | ⟨d, x, y, p', k', hxy, hp, hk⟩ + · exact Or.inl ⟨r, by simp [hr]⟩ + · exact Or.inr (Or.inl ⟨r, hr, by simp [he]⟩) + · exact Or.inr (Or.inr ⟨a :: d, x, y, p', k', hxy, by simp [hp], by simp [hk]⟩) + · exact Or.inr (Or.inr ⟨[], a, b, as, bs, hab, rfl, rfl⟩) + +theorem two_le_length {l : List UInt8} {x y : UInt8} (hx : x ∈ l) (hy : y ∈ l) (h : x ≠ y) : + 2 ≤ l.length := by + match l, hx, hy with + | [a], hx, hy => + simp at hx hy; exact absurd (hx.trans hy.symm) h + | _ :: _ :: _, _, _ => simp + +/-- In a list whose lengths strictly increase, the last element is the longest. -/ +theorem le_last_length : ∀ (l : List Path), l.Pairwise (fun a b => a.length < b.length) → + ∀ x ∈ l, x.length ≤ (l.getLast?.getD []).length + | [], _, x, hx => by cases hx + | [a], _, x, hx => by simp at hx; subst hx; simp + | a :: b :: rest, hp, x, hx => by + have hp' := List.pairwise_cons.mp hp + have ih := le_last_length (b :: rest) hp'.2 + have hlast : (a :: b :: rest).getLast? = (b :: rest).getLast? := by simp [List.getLast?_cons_cons] + rw [hlast] + rcases List.mem_cons.mp hx with rfl | hx' + · have := ih b List.mem_cons_self + have := hp'.1 b List.mem_cons_self + omega + · exact ih x hx' + +theorem properPrefixes_pairwise (p : Path) : + (Path.properPrefixes p).Pairwise (fun a b => a.length < b.length) := by + unfold Path.properPrefixes + rw [List.pairwise_map] + refine List.Pairwise.imp_of_mem ?_ List.pairwise_lt_range + intro a b ha hb hab + have := List.mem_range.mp ha; have := List.mem_range.mp hb + simp [List.length_take]; omega + +theorem take_mem_properPrefixes {p : Path} {j : Nat} (h : j < p.length) : + p.take j ∈ Path.properPrefixes p := + List.mem_map.mpr ⟨j, List.mem_range.mpr h, rfl⟩ + +theorem take_succ_append (d : Path) (x : UInt8) (r : Path) : + (d ++ x :: r).take (d.length + 1) = d ++ [x] := by + induction d with + | nil => simp + | cons c d ih => simp [ih] + +theorem mem_childMask_of {t : PathMap V} {d : Path} {x : UInt8} (h : d ++ [x] ∈ t.paths) : + x ∈ t.childMask d := by + unfold PathMap.childMask + rw [mem_ofList, List.mem_filterMap] + exact ⟨d ++ [x], h, by rw [Path.stripPrefix_append]⟩ + +/-- **`prune_path` removes no value**, on a trie whose locations are prefix-closed. -/ +theorem valAt_prunePath {t : PathMap V} (hc : PrefixClosed t) (rootLen : Nat) (p k : Path) : + (t.prunePath rootLen p).2.valAt k = t.valAt k := by + unfold PathMap.prunePath + simp only + split + · rfl + · next hn => + have hn0 : t.pruneCount rootLen p ≠ 0 := by simpa using hn + rw [PM.valAt_removeAt] + split + · next hck => + symm + cases hv : t.valAt k with + | none => rfl + | some v => + exfalso + -- unpack `pruneCount` + let stops := (Path.properPrefixes p).filter (fun a => + decide (a.length ≤ rootLen) || (t.valAt a).isSome || decide (t.childCount a ≥ 2)) + let a := (stops.getLast?).getD [] + have h1 : ¬ p.length ≤ rootLen := by + intro h; apply hn0; unfold PathMap.pruneCount; simp [h] + have h2 : t.isDanglingTip p = true := by + cases h : t.isDanglingTip p with + | true => rfl + | false => exfalso; apply hn0; unfold PathMap.pruneCount; simp [h1, h] + have hpc : t.pruneCount rootLen p = p.length - max rootLen a.length := by + unfold PathMap.pruneCount + simp only [h1, h2, if_false, Bool.not_true, Bool.false_eq_true] + rfl + have hm : max rootLen a.length < p.length := by + have := hn0; rw [hpc] at this; omega + have hcidx : p.length - t.pruneCount rootLen p + 1 = max rootLen a.length + 1 := by + rw [hpc]; omega + rw [hcidx] at hck + -- the stops: none of them is deeper than `max rootLen a.length` + have hstops : ∀ d ∈ stops, d.length ≤ a.length := + le_last_length stops ((properPrefixes_pairwise p).filter _) + have nonstop : ∀ d ∈ Path.properPrefixes p, max rootLen a.length < d.length → + t.valAt d = none ∧ t.childCount d < 2 := by + intro d hd hlt + have hnot : ¬ (decide (d.length ≤ rootLen) || (t.valAt d).isSome || + decide (t.childCount d ≥ 2)) = true := by + intro hcond + have := hstops d (List.mem_filter.mpr ⟨hd, hcond⟩) + omega + simp only [Bool.or_eq_true, decide_eq_true_eq, not_or] at hnot + refine ⟨?_, by omega⟩ + cases hd' : t.valAt d with + | none => rfl + | some _ => exact absurd (by rw [hd']; rfl) hnot.1.2 + -- the dangling tip + have hbare : t.entryAt p = .bare ∧ t.belowIsEmpty p = true := by + unfold PathMap.isDanglingTip at h2 + split at h2 + · next he => exact ⟨he, h2⟩ + · cases h2 + · cases h2 + have hpval : t.valAt p = none := by + show (t.entryAt p).val = none; rw [hbare.1]; rfl + have hppath : p ∈ t.paths := by + have := hbare.1 + unfold PathMap.entryAt at this + cases hl : t.entries.lookup p with + | none => rw [hl] at this; cases this + | some o => exact mem_keys_of_lookup_isSome (by rw [hl]; rfl) + have hkpath : k ∈ t.paths := valAt_isSome_mem_paths t (by rw [hv]; rfl) + obtain ⟨s, hks⟩ := (Path.isPrefixOf_iff _ _).mp hck + have hclen : (p.take (max rootLen a.length + 1)).length = max rootLen a.length + 1 := by + rw [List.length_take]; omega + rcases path_trichotomy p k with ⟨r, hr⟩ | ⟨r, hr, he⟩ | ⟨d, x, y, p', k', hxy, hp, hk⟩ + · -- `k` is at or below the tip + cases r with + | nil => rw [List.append_nil] at hr; subst hr; rw [hpval] at hv; cases hv + | cons b r => + have hbelow := hbare.2 + unfold PathMap.belowIsEmpty at hbelow + have := List.all_eq_true.mp hbelow k hkpath + have hpk : Path.isPrefixOf p k = true := (Path.isPrefixOf_iff _ _).mpr ⟨_, hr⟩ + simp only [hpk, Bool.not_true, Bool.false_or, beq_iff_eq] at this + rw [this] at hr + have := congrArg List.length hr; simp at this + · -- `k` is a proper ancestor of the tip, below the stop + have hkt : k = p.take k.length := by rw [he, List.take_left' rfl] + have hlen : k.length < p.length := by + rw [he, List.length_append] + have : r.length ≠ 0 := fun h => hr (List.length_eq_zero_iff.mp h) + omega + have hdeep : max rootLen a.length < k.length := by + have := congrArg List.length hks; rw [List.length_append, hclen] at this; omega + have := (nonstop k (by rw [hkt]; exact take_mem_properPrefixes hlen) hdeep).1 + rw [hv] at this; cases this + · -- `k` and the tip part ways at `d`, which must branch + have hdlen : d.length < p.length := by rw [hp]; simp + have hdeep : max rootLen a.length < d.length := by + apply Nat.lt_of_not_le + intro hle + apply hxy + have e1 : k.take (d.length + 1) = d ++ [y] := by rw [hk, take_succ_append] + have e2 : k.take (d.length + 1) = d ++ [x] := by + rw [hks, List.take_append_of_le_length (by rw [hclen]; omega), List.take_take, + Nat.min_def, if_pos (by omega), hp, take_succ_append] + rw [e2] at e1; simpa using e1 + have hdp : d ∈ Path.properPrefixes p := by + have : d = p.take d.length := by rw [hp, List.take_left' rfl] + rw [this]; exact take_mem_properPrefixes hdlen + have hcount := (nonstop d hdp hdeep).2 + have hx : x ∈ t.childMask d := mem_childMask_of (by + have := hc p hppath (d.length + 1); rwa [hp, take_succ_append] at this) + have hy : y ∈ t.childMask d := mem_childMask_of (by + have := hc k hkpath (d.length + 1); rwa [hk, take_succ_append] at this) + have := two_le_length hx hy hxy + unfold PathMap.childCount at hcount; omega + · rfl + + +theorem proj_prunePath {t : PathMap V} (hc : PrefixClosed t) (rootLen : Nat) (p : Path) : + proj (t.prunePath rootLen p).2 = proj t := + (proj_eq_proj_iff _ _).mpr (valAt_prunePath hc rootLen p) + +/-! ## 3. Zippers + +`πz` projects a `PathMapModel` zipper's trie and keeps its cursor. Every write +operation below commutes with it: + + πz (op_PathMapModel z …).2 = (op_PrunedModel (πz z) …).2 + +The proofs go through `Refine.lean`: the right-hand side is "write `M` at the +focus", so it is enough to show the left-hand side holds `M`'s values at and +below the focus and the old values elsewhere, which `projZ_of` packages. -/ + +/-- Forget a zipper's dangling paths. -/ +def projZ (z : Zip V) : PZip V := ⟨proj z.trie, z.root, z.path⟩ + +namespace Z +variable (z : Zip V) + +@[simp] theorem projZ_trie : (projZ z).trie = proj z.trie := rfl +@[simp] theorem projZ_focus : (projZ z).focus = z.focus := rfl +@[simp] theorem projZ_withTrie (t : PathMap V) : projZ (z.withTrie t) = (projZ z).withTrie (proj t) := rfl +theorem projZ_val : (projZ z).val = z.val := valAt_proj _ _ +theorem projZ_makeMap : (projZ z).makeMap = proj z.makeMap := (proj_subtrie _ _).symm +theorem projZ_focusNode : (projZ z).focusNode = proj z.focusNode := by + rw [PZip.focusNode, projZ_makeMap, Zip.focusNode, (proj_removeVal _ _).2] + +theorem valAt_focusNode_cons (b : UInt8) (r : Path) : + z.focusNode.valAt (b :: r) = z.trie.valAt (z.focus ++ b :: r) := by + rw [Zip.focusNode, PM.valAt_removeVal, if_neg (by simp), Zip.makeMap, PM.valAt_subtrie] + +theorem valAt_focusNode_nil : z.focusNode.valAt [] = none := by + rw [Zip.focusNode, PM.valAt_removeVal, if_pos rfl] + +theorem valAt_makeMap (k : Path) : z.makeMap.valAt k = z.trie.valAt (z.focus ++ k) := + PM.valAt_subtrie _ _ _ + +theorem isEmptyMap_valAt {t : PathMap V} (h : t.isEmptyMap = true) (k : Path) : t.valAt k = none := by + rw [PathMap.isEmptyMap, Bool.and_eq_true] at h + rw [← lookup_vals, List.isEmpty_iff.mp h.1]; rfl + +theorem eq_of_beqT {ops : ValOps V} (hbeq : LawfulBeqOps ops) {a b : PathMap V} + (h : PathMap.beqT ops a b = true) : a = b := by + rw [PathMap.beqT, Bool.and_eq_true, beq_iff_eq] at h + obtain ⟨hl, hz⟩ := h + have : a.entries = b.entries := by + have key : ∀ (l₁ l₂ : List (Path × Option V)), l₁.length = l₂.length → + (l₁.zip l₂).all (fun xy => xy.1.1 == xy.2.1 && + (match xy.1.2, xy.2.2 with + | none, none => true + | some x, some y => ops.beq x y + | _, _ => false)) = true → l₁ = l₂ := by + intro l₁ + induction l₁ with + | nil => intro l₂ hl _; cases l₂ <;> simp_all + | cons x xs ih => + intro l₂ hl hall + cases l₂ with + | nil => simp at hl + | cons y ys => + simp only [List.zip_cons_cons, List.all_cons, Bool.and_eq_true, beq_iff_eq] at hall + obtain ⟨⟨h1, h2⟩, h3⟩ := hall + have e := ih ys (by simpa using hl) h3 + obtain ⟨xk, xv⟩ := x; obtain ⟨yk, yv⟩ := y + simp only at h1 h2 + subst h1; subst e + cases xv <;> cases yv <;> simp at h2 ⊢ + exact hbeq _ _ h2 + exact key _ _ hl hz + cases a; cases b; simp_all + +/-- The packaging lemma: a zipper with `z`'s cursor whose trie holds `M` at and +below the focus and `z`'s values elsewhere projects to "write `M` at the focus". -/ +theorem projZ_of {zf : Zip V} (M : PrunedMap V) (hr : zf.root = z.root) (hp : zf.path = z.path) + (hout : ∀ k, k ≠ z.focus → (∀ r, k ≠ z.focus ++ r) → zf.trie.valAt k = z.trie.valAt k) + (hroot : zf.trie.valAt z.focus = M.valAt []) + (hbelow : ∀ b r, zf.trie.valAt (z.focus ++ b :: r) = M.valAt (b :: r)) : + projZ zf = (projZ z).withTrie ((proj z.trie).replaceAt z.focus M) := by + show (⟨proj zf.trie, zf.root, zf.path⟩ : PZip V) = ⟨_, z.root, z.path⟩ + rw [hr, hp] + congr 1 + apply PrunedMap.eq_replaceAt + · intro k hk; rw [valAt_proj, valAt_proj]; exact hout k (PrunedMap.ne_of_off hk) hk + · rw [valAt_proj]; exact hroot + · intro b r; rw [valAt_proj]; exact hbelow b r + +/-- `prune_path` keeps every value of a prefix-closed trie, and the cursor. -/ +theorem prunePath_snd (z' : Zip V) : + (z'.prunePath).2 = z'.withTrie (z'.trie.prunePath z'.root.length z'.focus).2 := rfl + +theorem valAt_prune_ite {z' : Zip V} (hc : PrefixClosed z'.trie) (prune : Bool) (k : Path) : + (if prune then (z'.prunePath).2 else z').trie.valAt k = z'.trie.valAt k := by + cases prune + · rfl + · show (z'.prunePath).2.trie.valAt k = _ + rw [prunePath_snd]; exact valAt_prunePath hc _ z'.focus k + +theorem prune_ite_cursor (z' : Zip V) (prune : Bool) : + (if prune then (z'.prunePath).2 else z').root = z'.root ∧ + (if prune then (z'.prunePath).2 else z').path = z'.path := by + cases prune <;> exact ⟨rfl, rfl⟩ + +theorem prefixClosed_removeVal (t : PathMap V) (p : Path) : PrefixClosed (t.removeVal p).2 := + prefixClosed_mk' _ _ +theorem prefixClosed_removeBelow (t : PathMap V) (p : Path) : PrefixClosed (t.removeBelow p) := + prefixClosed_mk' _ _ +theorem prefixClosed_graftBelow (t : PathMap V) (p : Path) (s : PathMap V) : + PrefixClosed (t.graftBelow p s) := prefixClosed_mk' _ _ + +/-- The value step of the algebraic operations, whichever branch it takes, leaves +the cursor alone and changes at most the focus value. -/ +structure ValueStep (z z1 : Zip V) (rv : Option V) : Prop where + root : z1.root = z.root + path : z1.path = z.path + off : ∀ k, k ≠ z.focus → z1.trie.valAt k = z.trie.valAt k + at_focus : z1.trie.valAt z.focus = rv + +theorem ValueStep.focus {z z1 : Zip V} {rv : Option V} (h : ValueStep z z1 rv) : z1.focus = z.focus := by + show z1.root ++ z1.path = z.root ++ z.path; rw [h.root, h.path] + +theorem valueStep_self : ValueStep z z z.val := ⟨rfl, rfl, fun _ _ => rfl, rfl⟩ + +theorem valueStep_setVal (v : V) : ValueStep z (z.setVal v).2 (some v) where + root := rfl + path := rfl + off k hk := by + show (z.trie.setVal z.focus v).2.valAt k = _; rw [PM.valAt_setVal, if_neg hk] + at_focus := by show (z.trie.setVal z.focus v).2.valAt z.focus = _; rw [PM.valAt_setVal, if_pos rfl] + +theorem valueStep_removeVal (prune : Bool) : ValueStep z (z.removeVal prune).2 none := by + have hc := prefixClosed_removeVal z.trie z.focus + show ValueStep z (if prune then ((z.withTrie (z.trie.removeVal z.focus).2).prunePath).2 + else z.withTrie (z.trie.removeVal z.focus).2) none + refine ⟨(prune_ite_cursor _ prune).1, (prune_ite_cursor _ prune).2, ?_, ?_⟩ + · intro k hk + rw [valAt_prune_ite hc] + show (z.trie.removeVal z.focus).2.valAt k = _ + rw [PM.valAt_removeVal, if_neg hk] + · rw [valAt_prune_ite hc] + show (z.trie.removeVal z.focus).2.valAt z.focus = _ + rw [PM.valAt_removeVal, if_pos rfl] + +theorem prefixClosed_setVal' (v : V) : PrefixClosed (z.setVal v).2.trie := prefixClosed_mk' _ _ +theorem prefixClosed_removeVal' : PrefixClosed (z.removeVal false).2.trie := prefixClosed_mk' _ _ + +/-- Where a prefix-closed trie has no location, nothing lies at or below it. -/ +theorem valAt_of_not_pathExists {t : PathMap V} (hc : PrefixClosed t) {p : Path} + (h : t.pathExists p = false) (r : Path) : t.valAt (p ++ r) = none := by + cases hv : t.valAt (p ++ r) with + | none => rfl + | some v => + exfalso + have hm := valAt_isSome_mem_paths t (k := p ++ r) (by rw [hv]; rfl) + have hp : p ∈ t.paths := by simpa using hc _ hm p.length + obtain ⟨kv, hmem, heq⟩ := List.mem_map.mp hp + have hl : (t.entries.lookup p).isSome = true := + List.lookup_isSome_iff.mpr ⟨kv, hmem, by simp [heq]⟩ + unfold PathMap.pathExists PathMap.entryAt at h + obtain ⟨x, hx⟩ := Option.isSome_iff_exists.mp hl + rw [hx] at h + cases x <;> cases h + +end Z + +namespace Z +variable (z : Zip V) +open PrunedMap (valAt_setVal valAt_removeVal valAt_withRootOf_nil valAt_withRootOf_cons + valAt_restrictBelowRoot valAt_prepend valAt_join valAt_meet valAt_sub) + +/-- A zipper that took a value step and nothing else. -/ +theorem projZ_of_valueStep {z1 : Zip V} {rv : Option V} (h : ValueStep z z1 rv) (M : PrunedMap V) + (hroot : rv = M.valAt []) + (hbelow : ∀ b r, z.trie.valAt (z.focus ++ b :: r) = M.valAt (b :: r)) : + projZ z1 = (projZ z).withTrie ((proj z.trie).replaceAt z.focus M) := + projZ_of z M h.root h.path (fun k hk _ => h.off k hk) (by rw [h.at_focus]; exact hroot) + (fun b r => by rw [h.off _ (by simp)]; exact hbelow b r) + +theorem focus_cons_ne (b : UInt8) (r : Path) : z.focus ++ b :: r ≠ z.focus := by simp + +/-! ### Values at the focus -/ + +theorem proj_setVal (v : V) : + (z.setVal v).1 = ((projZ z).setVal v).1 ∧ projZ (z.setVal v).2 = ((projZ z).setVal v).2 := by + refine ⟨(projZ_val z).symm, ?_⟩ + rw [PZip.setVal_eq] + apply projZ_of_valueStep z (valueStep_setVal z v) + · rw [valAt_setVal, if_pos rfl] + · intro b r + rw [valAt_setVal, if_neg (by simp), PZip.valAt_makeMap, projZ_trie, valAt_proj]; rfl + +theorem proj_removeVal (prune : Bool) : + (z.removeVal prune).1 = ((projZ z).removeVal).1 ∧ + projZ (z.removeVal prune).2 = ((projZ z).removeVal).2 := by + refine ⟨?_, ?_⟩ + · show z.val = _ + unfold PZip.removeVal + rw [projZ_val] + cases z.val <;> rfl + · rw [PZip.removeVal_eq] + apply projZ_of_valueStep z (valueStep_removeVal z prune) + · rw [valAt_removeVal, if_pos rfl] + · intro b r + rw [valAt_removeVal, if_neg (by simp), PZip.valAt_makeMap, projZ_trie, valAt_proj]; rfl + +/-- `create_path` only makes a dangling path. -/ +theorem proj_createPath : projZ (z.createPath).2 = projZ z := by + unfold Zip.createPath + split + · rfl + · split + · show projZ (z.withTrie _) = _ + rw [projZ_withTrie, proj_addPath]; rfl + · rfl + · rfl + +/-- `prune_path` only removes dangling paths — on a prefix-closed trie, which is +every trie an operation returns. -/ +theorem proj_prunePath (hc : PrefixClosed z.trie) : projZ (z.prunePath).2 = (projZ z) := by + rw [prunePath_snd, projZ_withTrie, Project.proj_prunePath hc]; rfl + +/-- A trailing `prune_path`, as every `prune = true` operation now ends, is +invisible to the projection. -/ +theorem projZ_prune_ite {w : Zip V} (hc : PrefixClosed w.trie) (prune : Bool) : + projZ (if prune then (w.prunePath).2 else w) = projZ w := by + cases prune + · rfl + · exact proj_prunePath w hc + +/-! ### Grafting and removing subtries -/ + +theorem graftMap_trie_valAt (m : PathMap V) (k : Path) : + (z.graftMap m).trie.valAt k = + if k = z.focus then m.valAt [] + else match Path.stripPrefix z.focus k with + | some (b :: r) => m.valAt (b :: r) + | _ => z.trie.valAt k := by + show (match m.valAt [] with + | some v => ((z.trie.graftBelow z.focus m).setVal z.focus v).2 + | none => ((z.trie.graftBelow z.focus m).removeVal z.focus).2).valAt k = _ + cases hm : m.valAt [] with + | none => + simp only + rw [PM.valAt_removeVal, PM.valAt_graftBelow] + | some v => + simp only + rw [PM.valAt_setVal, PM.valAt_graftBelow] + +theorem proj_graftMap (m : PathMap V) : projZ (z.graftMap m) = (projZ z).graftMap (proj m) := by + rw [PZip.graftMap_eq] + apply projZ_of z (zf := z.graftMap m) (proj m) rfl rfl + · intro k hk hk' + rw [graftMap_trie_valAt, if_neg hk, PrunedMap.stripPrefix_off hk'] + · rw [graftMap_trie_valAt, if_pos rfl, valAt_proj] + · intro b r + rw [graftMap_trie_valAt, if_neg (focus_cons_ne z b r), Path.stripPrefix_append, valAt_proj] + +theorem proj_graft (src : Zip V) : projZ (z.graft src) = (projZ z).graft (projZ src) := by + rw [Zip.graft, proj_graftMap, PZip.graft, projZ_makeMap] + +theorem proj_removeBranches (prune : Bool) : + projZ (z.removeBranches prune).2 = ((projZ z).removeBranches).2 := by + rw [PZip.removeBranches_eq] + have hc := prefixClosed_removeBelow z.trie z.focus + have e : (z.removeBranches prune).2 = if prune then ((z.withTrie (z.trie.removeBelow z.focus)).prunePath).2 + else z.withTrie (z.trie.removeBelow z.focus) := rfl + rw [e] + apply projZ_of z _ (prune_ite_cursor (z.withTrie (z.trie.removeBelow z.focus)) prune).1 + (prune_ite_cursor (z.withTrie (z.trie.removeBelow z.focus)) prune).2 + · intro k _ hk + rw [valAt_prune_ite hc]; exact PM.valAt_removeBelow_off' hk + · rw [valAt_prune_ite hc, valAt_withRootOf_nil, PZip.makeMap_valAt_nil, projZ_val] + show (z.trie.removeBelow z.focus).valAt z.focus = _ + rw [PM.valAt_removeBelow]; simp; rfl + · intro b r + rw [valAt_prune_ite hc, valAt_withRootOf_cons] + show (z.trie.removeBelow z.focus).valAt _ = _ + rw [PM.valAt_removeBelow, if_pos ⟨(Path.isPrefixOf_iff _ _).mpr ⟨_, rfl⟩, by simp⟩]; rfl + +end Z + +namespace Z +variable (z : Zip V) +open PrunedMap (valAt_setVal valAt_removeVal valAt_withRootOf_nil valAt_withRootOf_cons + valAt_restrictBelowRoot valAt_prepend valAt_join valAt_meet valAt_sub) + +/-! ### How the algebraic operations end + +After the value step (`ValueStep z z1 rv`) each operation keeps `z1`, grafts a +node below the focus, or removes everything below it — the last two possibly +followed by `prune_path`. Each ending is one lemma. -/ + +theorem belowIsEmpty_valAt {t : PathMap V} {f : Path} (h : t.belowIsEmpty f = true) (b : UInt8) + (r : Path) : t.valAt (f ++ b :: r) = none := by + cases hv : t.valAt (f ++ b :: r) with + | none => rfl + | some v => + exfalso + have hm := valAt_isSome_mem_paths t (k := f ++ b :: r) (by rw [hv]; rfl) + have := List.all_eq_true.mp h _ hm + have hp : Path.isPrefixOf f (f ++ b :: r) = true := (Path.isPrefixOf_iff _ _).mpr ⟨_, rfl⟩ + simp only [hp, Bool.not_true, Bool.false_or, beq_iff_eq] at this + have := congrArg List.length this; simp at this + +theorem leaf_graft_ite {z1 : Zip V} {rv : Option V} (h : ValueStep z z1 rv) (R : PathMap V) + (M : PrunedMap V) (hroot : rv = M.valAt []) + (hbelow : ∀ b r, R.valAt (b :: r) = M.valAt (b :: r)) (prune : Bool) : + projZ (if prune then ((z1.withTrie (z1.trie.graftBelow z1.focus R)).prunePath).2 + else z1.withTrie (z1.trie.graftBelow z1.focus R)) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus M) := by + have hc := prefixClosed_graftBelow z1.trie z1.focus R + have hf := h.focus + apply projZ_of z (zf := if prune then ((z1.withTrie (z1.trie.graftBelow z1.focus R)).prunePath).2 + else z1.withTrie (z1.trie.graftBelow z1.focus R)) M + ((prune_ite_cursor (z1.withTrie (z1.trie.graftBelow z1.focus R)) prune).1.trans h.root) + ((prune_ite_cursor (z1.withTrie (z1.trie.graftBelow z1.focus R)) prune).2.trans h.path) + · intro k hk hk' + rw [valAt_prune_ite (z' := z1.withTrie (z1.trie.graftBelow z1.focus R)) hc] + show (z1.trie.graftBelow z1.focus R).valAt k = _ + rw [PM.valAt_graftBelow, hf, PrunedMap.stripPrefix_off hk'] + exact h.off k hk + · rw [valAt_prune_ite (z' := z1.withTrie (z1.trie.graftBelow z1.focus R)) hc] + show (z1.trie.graftBelow z1.focus R).valAt z.focus = _ + rw [PM.valAt_graftBelow, hf, PZip.stripPrefix_self, h.at_focus]; exact hroot + · intro b r + rw [valAt_prune_ite (z' := z1.withTrie (z1.trie.graftBelow z1.focus R)) hc] + show (z1.trie.graftBelow z1.focus R).valAt _ = _ + rw [PM.valAt_graftBelow, hf, Path.stripPrefix_append]; exact hbelow b r + +theorem leaf_graft' {z1 : Zip V} {rv : Option V} (h : ValueStep z z1 rv) (R : PathMap V) + (M : PrunedMap V) (hroot : rv = M.valAt []) + (hbelow : ∀ b r, R.valAt (b :: r) = M.valAt (b :: r)) : + projZ (z1.withTrie (z1.trie.graftBelow z1.focus R)) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus M) := + leaf_graft_ite z h R M hroot hbelow false + +theorem leaf_removeBelow_ite {z1 : Zip V} {rv : Option V} (h : ValueStep z z1 rv) + (M : PrunedMap V) (hroot : rv = M.valAt []) (hbelow : ∀ b r, M.valAt (b :: r) = none) + (prune : Bool) : + projZ (if prune then ((z1.withTrie (z1.trie.removeBelow z1.focus)).prunePath).2 + else z1.withTrie (z1.trie.removeBelow z1.focus)) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus M) := by + have hc := prefixClosed_removeBelow z1.trie z1.focus + have hf := h.focus + apply projZ_of z (zf := if prune then ((z1.withTrie (z1.trie.removeBelow z1.focus)).prunePath).2 + else z1.withTrie (z1.trie.removeBelow z1.focus)) M + ((prune_ite_cursor (z1.withTrie (z1.trie.removeBelow z1.focus)) prune).1.trans h.root) + ((prune_ite_cursor (z1.withTrie (z1.trie.removeBelow z1.focus)) prune).2.trans h.path) + · intro k hk hk' + rw [valAt_prune_ite (z' := z1.withTrie (z1.trie.removeBelow z1.focus)) hc] + show (z1.trie.removeBelow z1.focus).valAt k = _ + rw [hf, PM.valAt_removeBelow_off' hk']; exact h.off k hk + · rw [valAt_prune_ite (z' := z1.withTrie (z1.trie.removeBelow z1.focus)) hc] + show (z1.trie.removeBelow z1.focus).valAt z.focus = _ + rw [hf, PM.valAt_removeBelow]; simp only [ne_eq, not_true_eq_false, and_false, if_false] + rw [h.at_focus]; exact hroot + · intro b r + rw [valAt_prune_ite (z' := z1.withTrie (z1.trie.removeBelow z1.focus)) hc] + show (z1.trie.removeBelow z1.focus).valAt _ = _ + rw [hf, PM.valAt_removeBelow, if_pos ⟨(Path.isPrefixOf_iff _ _).mpr ⟨_, rfl⟩, by simp⟩, hbelow] + +theorem leaf_removeBelow' {z1 : Zip V} {rv : Option V} (h : ValueStep z z1 rv) + (M : PrunedMap V) (hroot : rv = M.valAt []) (hbelow : ∀ b r, M.valAt (b :: r) = none) : + projZ (z1.withTrie (z1.trie.removeBelow z1.focus)) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus M) := + leaf_removeBelow_ite z h M hroot hbelow false + +/-- `nodeStatus … = identity` means the computed node is the one already there. -/ +theorem eq_of_nodeStatus {ops : ValOps V} (hbeq : LawfulBeqOps ops) {a b : PathMap V} + (h : (Zip.nodeStatus ops a b == AlgStatus.identity) = true) : b = a := by + unfold Zip.nodeStatus at h + by_cases he : b.isEmptyMap = true + · simp [he] at h + · by_cases hb : PathMap.beqT ops b a = true + · exact eq_of_beqT hbeq hb + · simp [he, hb] at h + +theorem focusNode_eq_of_valueStep {z1 : Zip V} {rv : Option V} (h : ValueStep z z1 rv) (b : UInt8) + (r : Path) : z1.focusNode.valAt (b :: r) = z.trie.valAt (z.focus ++ b :: r) := by + rw [valAt_focusNode_cons, h.focus, h.off _ (focus_cons_ne z b r)] + +/-! ### Path surgery and node-level operations -/ + +/-- `insert_prefix` — on a prefix-closed trie, since `PathMapModel` decides +whether the focus exists from its locations and the pruned model from its +values. -/ +theorem proj_insertPrefix (pre : Path) (hc : PrefixClosed z.trie) : + projZ (z.insertPrefix pre).2 = ((projZ z).insertPrefix pre).2 := by + rw [PZip.insertPrefix_eq] + unfold Zip.insertPrefix + by_cases hx : z.pathExists = true + · simp only [hx, Bool.not_true, Bool.false_eq_true, if_false] + by_cases hp : pre.isEmpty = true + · simp only [hp, if_true] + rw [List.isEmpty_iff.mp hp, PZip.prepend_nil] + apply projZ_of_valueStep z (valueStep_self z) + · rw [PZip.makeMap_valAt_nil, projZ_val] + · intro b r; rw [PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj] + · simp only [hp, Bool.false_eq_true, if_false] + show projZ (z.graftMap (PM.shift z.makeMap pre)) = _ + rw [proj_graftMap, proj_shift, ← projZ_makeMap, PZip.graftMap_eq] + · have hx' : z.pathExists = false := by simpa using hx + simp only [hx', Bool.not_false, if_true] + have hnone : ∀ r, z.trie.valAt (z.focus ++ r) = none := + valAt_of_not_pathExists (t := z.trie) hc hx' + apply projZ_of_valueStep z (valueStep_self z) + · have h0 := hnone []; rw [List.append_nil] at h0 + show z.trie.valAt z.focus = _ + rw [h0, valAt_prepend] + split + · next q _ => rw [PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj, hnone] + · rfl + · intro b r + rw [hnone, valAt_prepend] + split + · next q _ => rw [PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj, hnone] + · rfl + +theorem proj_joinInto {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : Zip V) : + projZ (z.joinInto ops src).2 = ((projZ z).joinInto ops (projZ src)).2 := by + rw [PZip.joinInto_eq _ hbeq] + have hval : ∀ b r, (PrunedMap.join ops (projZ z).makeMap (projZ src).makeMap).valAt (b :: r) = + PrunedMap.joinVal ops (z.trie.valAt (z.focus ++ b :: r)) (src.focusNode.valAt (b :: r)) := by + intro b r + simp only [valAt_join, PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj, + valAt_focusNode_cons] + have tail : ∀ (z1 : Zip V) (rv : Option V), ValueStep z z1 rv → + rv = PrunedMap.joinVal ops z.val src.val → ∀ (s1 s2 s3 : AlgStatus), + projZ ((if src.focusNode.isEmptyMap = true then (s1, z1) + else if PathMap.beqT ops (PathMap.join ops z1.focusNode src.focusNode) z1.focusNode = true + then (s2, z1) + else (s3, z1.withTrie (z1.trie.graftBelow z1.focus + (PathMap.join ops z1.focusNode src.focusNode)))).2) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus + (PrunedMap.join ops (projZ z).makeMap (projZ src).makeMap)) := by + intro z1 rv h hrv s1 s2 s3 + have hroot : rv = (PrunedMap.join ops (projZ z).makeMap (projZ src).makeMap).valAt [] := by + rw [valAt_join, PZip.makeMap_valAt_nil, PZip.makeMap_valAt_nil, projZ_val, projZ_val, hrv] + simp only [apply_ite Prod.snd] + split + · next hE => + apply projZ_of_valueStep z h _ hroot + intro b r; rw [hval, isEmptyMap_valAt hE, PrunedMap.joinVal_none_right] + · split + · next _ hb => + have e := eq_of_beqT hbeq hb + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, ← PM.valAt_join, e] + · apply leaf_graft' z h _ _ hroot + intro b r; rw [hval, PM.valAt_join, focusNode_eq_of_valueStep z h] + unfold Zip.joinInto + cases hz : z.val with + | none => + cases hs : src.val with + | none => + dsimp only + exact tail z _ (valueStep_self z) (by rw [hz, hs]; rfl) _ _ _ + | some mv => + dsimp only + exact tail (z.setVal mv).2 (some mv) (valueStep_setVal z mv) (by rw [hz, hs]; rfl) _ _ _ + | some sv => + cases hs : src.val with + | none => + dsimp only + exact tail z _ (valueStep_self z) (by rw [hz, hs]; rfl) _ _ _ + | some mv => + cases hr : (ops.pjoin sv mv).resolve sv mv with + | none => + simp only [hr] + exact tail (z.removeVal false).2 none (valueStep_removeVal z false) (by rw [hz, hs]; exact hr.symm) _ _ _ + | some v => + simp only [hr] + exact tail (z.setVal v).2 (some v) (valueStep_setVal z v) (by rw [hz, hs]; exact hr.symm) _ _ _ + +theorem proj_restrict {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : Zip V) : + projZ (z.restrict ops src).2 = ((projZ z).restrict ops (projZ src)).2 := by + rw [PZip.restrict_eq _ hbeq, projZ_val src] + unfold Zip.restrict + by_cases hs : src.val.isSome = true + · rw [if_pos hs, if_pos hs] + apply projZ_of_valueStep z (valueStep_self z) + · rw [PZip.makeMap_valAt_nil, projZ_val] + · intro b r; rw [PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj] + rw [if_neg hs, if_neg hs] + have hroot : (none : Option V) = + (PrunedMap.restrictBelowRoot (projZ z).makeMap (projZ src).makeMap).valAt [] := by + rw [valAt_restrictBelowRoot]; rfl + have hvb : ∀ q, PrunedMap.validatedBy (proj src.focusNode) q = + PrunedMap.validatedBy (projZ src).makeMap q := + PrunedMap.validatedBy_congr (fun c r => by + rw [valAt_proj, valAt_focusNode_cons, PZip.valAt_makeMap, projZ_trie, valAt_proj]; rfl) + have hval : ∀ b r, (PrunedMap.restrictBelowRoot (projZ z).makeMap (projZ src).makeMap).valAt + (b :: r) = if PrunedMap.validatedBy (proj src.focusNode) (b :: r) + then z.trie.valAt (z.focus ++ b :: r) else none := by + intro b r + rw [valAt_restrictBelowRoot, hvb, PZip.valAt_makeMap, projZ_trie, valAt_proj]; rfl + have tail : ∀ (z1 : Zip V), ValueStep z z1 none → ∀ (s1 s2 s3 s4 : AlgStatus), + projZ ((if src.focusNode.isEmptyMap = true then (s1, z1.withTrie (z1.trie.removeBelow z1.focus)) + else if z1.focusNode.isEmptyMap = true then (s2, z1) + else if (Zip.nodeStatus ops z1.focusNode + (PathMap.restrictBelowRoot z1.focusNode src.focusNode) == AlgStatus.identity) = true + then (s3, z1) + else (s4, z1.withTrie (z1.trie.graftBelow z1.focus + (PathMap.restrictBelowRoot z1.focusNode src.focusNode)))).2) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus + (PrunedMap.restrictBelowRoot (projZ z).makeMap (projZ src).makeMap)) := by + intro z1 h s1 s2 s3 s4 + simp only [apply_ite Prod.snd] + split + · next hE => + apply leaf_removeBelow' z h _ hroot + intro b r + rw [hval, PrunedMap.validatedBy_congr (b := PrunedMap.empty) + (fun c r => by rw [valAt_proj, isEmptyMap_valAt hE]; rfl), PrunedMap.validatedBy_empty] + rfl + · split + · next _ hE => + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, isEmptyMap_valAt hE]; split <;> rfl + · split + · next _ _ hid => + have e := eq_of_nodeStatus hbeq hid + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, ← e, PM.valAt_restrictBelowRoot, + focusNode_eq_of_valueStep z h] + by_cases hv : PrunedMap.validatedBy (proj src.focusNode) (b :: r) = true <;> simp [hv] + · apply leaf_graft' z h _ _ hroot + intro b r + rw [hval, PM.valAt_restrictBelowRoot, focusNode_eq_of_valueStep z h] + exact tail _ (valueStep_removeVal z false) _ _ _ _ + +theorem proj_meet2 {ops : ValOps V} (a b : Zip V) : + projZ (z.meet2 ops a b).2 = ((projZ z).meet2 ops (projZ a) (projZ b)).2 := by + show projZ (z.graftMap (PathMap.meet ops a.makeMap b.makeMap)) = + (projZ z).graftMap (PrunedMap.meet ops (projZ a).makeMap (projZ b).makeMap) + rw [proj_graftMap, proj_meet, projZ_makeMap, projZ_makeMap] + +theorem proj_takeMap (prune : Bool) : projZ (z.takeMap prune).2 = ((projZ z).takeMap).2 := by + rw [PZip.takeMap_snd] + exact leaf_removeBelow_ite z (valueStep_removeVal z false) PrunedMap.empty rfl (fun _ _ => rfl) prune + +/-! ### The algebraic operations with a value step -/ + +theorem proj_joinMapInto {ops : ValOps V} (hbeq : LawfulBeqOps ops) (m : PathMap V) : + projZ (z.joinMapInto ops m).2 = ((projZ z).joinMapInto ops (proj m)).2 := by + rw [PZip.joinMapInto_eq _ hbeq] + have tail : ∀ (z1 : Zip V) (rv : Option V), ValueStep z z1 rv → + rv = PrunedMap.joinVal ops z.val (m.valAt []) → + projZ (if (m.removeVal []).2.isEmptyMap = true then z1 + else if ((if PathMap.beqT ops (PathMap.join ops z1.focusNode (m.removeVal []).2) z1.focusNode + = true then AlgStatus.identity else AlgStatus.element) == AlgStatus.identity) = true + then z1 + else z1.withTrie (z1.trie.graftBelow z1.focus + (PathMap.join ops z1.focusNode (m.removeVal []).2))) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus + (PrunedMap.join ops (projZ z).makeMap (proj m))) := by + intro z1 rv h hrv + have hroot : rv = (PrunedMap.join ops (projZ z).makeMap (proj m)).valAt [] := by + rw [valAt_join, PZip.makeMap_valAt_nil, projZ_val, valAt_proj, hrv] + have hval : ∀ b r, (PrunedMap.join ops (projZ z).makeMap (proj m)).valAt (b :: r) = + PrunedMap.joinVal ops (z.trie.valAt (z.focus ++ b :: r)) (m.valAt (b :: r)) := by + intro b r + simp only [valAt_join, PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj] + have hsrc : ∀ b r, (m.removeVal []).2.valAt (b :: r) = m.valAt (b :: r) := by + intro b r; rw [PM.valAt_removeVal, if_neg (by simp)] + split + · next hE => + apply projZ_of_valueStep z h _ hroot + intro b r; rw [hval, ← hsrc, isEmptyMap_valAt hE, PrunedMap.joinVal_none_right] + · split + · next _ hid => + have e : PathMap.join ops z1.focusNode (m.removeVal []).2 = z1.focusNode := by + by_cases hb : PathMap.beqT ops (PathMap.join ops z1.focusNode (m.removeVal []).2) + z1.focusNode = true + · exact eq_of_beqT hbeq hb + · simp [hb] at hid + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, ← hsrc, ← PM.valAt_join, e] + · apply leaf_graft' z h _ _ hroot + intro b r + rw [hval, PM.valAt_join, hsrc, focusNode_eq_of_valueStep z h] + unfold Zip.joinMapInto + cases hz : z.val with + | none => + cases hm : m.valAt [] with + | none => + simp only [apply_ite Prod.snd] + exact tail z _ (valueStep_self z) (by rw [hz, hm]; rfl) + | some mv => + simp only [apply_ite Prod.snd] + exact tail _ _ (valueStep_setVal z mv) (by rw [hz, hm]; rfl) + | some sv => + cases hm : m.valAt [] with + | none => + simp only [apply_ite Prod.snd] + exact tail z _ (valueStep_self z) (by rw [hz, hm]; rfl) + | some mv => + cases hr : (ops.pjoin sv mv).resolve sv mv with + | none => + simp only [apply_ite Prod.snd, hr] + exact tail _ _ (valueStep_removeVal z false) (by rw [hz, hm]; exact hr.symm) + | some v => + simp only [apply_ite Prod.snd, hr] + exact tail _ _ (valueStep_setVal z v) (by rw [hz, hm]; exact hr.symm) + +end Z + +namespace Z +variable (z : Zip V) +open PrunedMap (valAt_meet valAt_sub) + +/-- `meet_into` — on a prefix-closed trie when `prune` is set, since the trailing +`prune_path` may then run on the trie as it was. -/ +theorem proj_meetInto {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : Zip V) (prune : Bool) + (hc : PrefixClosed z.trie) : + projZ (z.meetInto ops src prune).2 = ((projZ z).meetInto ops (projZ src)).2 := by + rw [PZip.meetInto_eq _ hbeq] + have hval : ∀ b r, (PrunedMap.meet ops (projZ z).makeMap (projZ src).makeMap).valAt (b :: r) = + PrunedMap.meetVal ops (z.trie.valAt (z.focus ++ b :: r)) (src.focusNode.valAt (b :: r)) := by + intro b r + simp only [valAt_meet, PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj, + valAt_focusNode_cons] + have tail : ∀ (z1 : Zip V) (rv : Option V), ValueStep z z1 rv → PrefixClosed z1.trie → + rv = PrunedMap.meetVal ops z.val src.val → ∀ (s1 s2 s3 : AlgStatus), + let W := (if z1.focusNode.isEmptyMap = true then (s1, z1) + else if src.focusNode.isEmptyMap = true then (s2, z1.withTrie (z1.trie.removeBelow z1.focus)) + else (s3, if (Zip.nodeStatus ops z1.focusNode (PathMap.meet ops z1.focusNode src.focusNode) + == AlgStatus.identity) = true then z1 + else z1.withTrie (z1.trie.graftBelow z1.focus + (PathMap.meet ops z1.focusNode src.focusNode)))).2 + projZ (if prune = true then (W.prunePath).2 else W) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus + (PrunedMap.meet ops (projZ z).makeMap (projZ src).makeMap)) := by + intro z1 rv h hc1 hrv s1 s2 s3 W + have hroot : rv = (PrunedMap.meet ops (projZ z).makeMap (projZ src).makeMap).valAt [] := by + rw [valAt_meet, PZip.makeMap_valAt_nil, PZip.makeMap_valAt_nil, projZ_val, projZ_val, hrv] + by_cases hE : z1.focusNode.isEmptyMap = true + · have e : W = z1 := by simp only [W, hE, if_true] + rw [e, projZ_prune_ite hc1] + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, isEmptyMap_valAt hE]; rfl + by_cases hS : src.focusNode.isEmptyMap = true + · have e : W = z1.withTrie (z1.trie.removeBelow z1.focus) := by + simp only [W, hE, hS, if_true, if_false, Bool.false_eq_true] + rw [e] + apply leaf_removeBelow_ite z h _ hroot + intro b r; rw [hval, isEmptyMap_valAt hS, PrunedMap.meetVal_none_right] + by_cases hid : (Zip.nodeStatus ops z1.focusNode (PathMap.meet ops z1.focusNode src.focusNode) + == AlgStatus.identity) = true + · have e : W = z1 := by simp only [W, hE, hS, hid, if_true, if_false, Bool.false_eq_true] + rw [e, projZ_prune_ite hc1] + have e' := eq_of_nodeStatus hbeq hid + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, ← PM.valAt_meet, e'] + · have e : W = z1.withTrie (z1.trie.graftBelow z1.focus + (PathMap.meet ops z1.focusNode src.focusNode)) := by + simp only [W, hE, hS, hid, if_false, Bool.false_eq_true] + rw [e] + apply leaf_graft_ite z h _ _ hroot + intro b r; rw [hval, PM.valAt_meet, focusNode_eq_of_valueStep z h] + unfold Zip.meetInto Zip.meetIntoWithoutPrune + cases hz : z.val with + | none => + cases hs : src.val with + | none => exact tail z _ (valueStep_self z) hc (by rw [hz, hs]; rfl) _ _ _ + | some ov => exact tail z _ (valueStep_self z) hc (by rw [hz, hs]; rfl) _ _ _ + | some sv => + cases hs : src.val with + | none => + exact tail _ _ (valueStep_removeVal z false) (prefixClosed_removeVal' z) + (by rw [hz, hs]; rfl) _ _ _ + | some ov => + cases hr : (ops.pmeet sv ov).resolve sv ov with + | none => + simp only [hr] + exact tail _ _ (valueStep_removeVal z false) (prefixClosed_removeVal' z) + (by rw [hz, hs]; exact hr.symm) _ _ _ + | some v => + simp only [hr] + exact tail _ _ (valueStep_setVal z v) (prefixClosed_setVal' z v) + (by rw [hz, hs]; exact hr.symm) _ _ _ + +/-- `subtract_into` — on a prefix-closed trie when `prune` is set, as for +`meet_into`. -/ +theorem proj_subtractInto {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : Zip V) (prune : Bool) + (hc : PrefixClosed z.trie) : + projZ (z.subtractInto ops src prune).2 = ((projZ z).subtractInto ops (projZ src)).2 := by + rw [PZip.subtractInto_eq _ hbeq] + have hval : ∀ b r, (PrunedMap.sub ops (projZ z).makeMap (projZ src).makeMap).valAt (b :: r) = + PrunedMap.subVal ops (z.trie.valAt (z.focus ++ b :: r)) (src.focusNode.valAt (b :: r)) := by + intro b r + simp only [valAt_sub, PZip.valAt_makeMap, projZ_trie, projZ_focus, valAt_proj, + valAt_focusNode_cons] + have tail : ∀ (z1 : Zip V) (rv : Option V), ValueStep z z1 rv → PrefixClosed z1.trie → + rv = PrunedMap.subVal ops z.val src.val → ∀ (s1 s2 s3 : AlgStatus), + let W := (if src.focusNode.isEmptyMap = true then (s1, z1) + else if z1.focusNode.isEmptyMap = true then (s2, z1) + else (s3, if (Zip.nodeStatus ops z1.focusNode (PathMap.sub ops z1.focusNode src.focusNode) + == AlgStatus.identity) = true then z1 + else z1.withTrie (z1.trie.graftBelow z1.focus + (PathMap.sub ops z1.focusNode src.focusNode)))).2 + projZ (if prune = true then (W.prunePath).2 else W) = + (projZ z).withTrie ((proj z.trie).replaceAt z.focus + (PrunedMap.sub ops (projZ z).makeMap (projZ src).makeMap)) := by + intro z1 rv h hc1 hrv s1 s2 s3 W + have hroot : rv = (PrunedMap.sub ops (projZ z).makeMap (projZ src).makeMap).valAt [] := by + rw [valAt_sub, PZip.makeMap_valAt_nil, PZip.makeMap_valAt_nil, projZ_val, projZ_val, hrv] + by_cases hS : src.focusNode.isEmptyMap = true + · have e : W = z1 := by simp only [W, hS, if_true] + rw [e, projZ_prune_ite hc1] + apply projZ_of_valueStep z h _ hroot + intro b r; rw [hval, isEmptyMap_valAt hS, PrunedMap.subVal_none_right] + by_cases hE : z1.focusNode.isEmptyMap = true + · have e : W = z1 := by simp only [W, hE, hS, if_true, if_false, Bool.false_eq_true] + rw [e, projZ_prune_ite hc1] + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, isEmptyMap_valAt hE]; rfl + by_cases hid : (Zip.nodeStatus ops z1.focusNode (PathMap.sub ops z1.focusNode src.focusNode) + == AlgStatus.identity) = true + · have e : W = z1 := by simp only [W, hE, hS, hid, if_true, if_false, Bool.false_eq_true] + rw [e, projZ_prune_ite hc1] + have e' := eq_of_nodeStatus hbeq hid + apply projZ_of_valueStep z h _ hroot + intro b r + rw [hval, ← focusNode_eq_of_valueStep z h, ← PM.valAt_sub, e'] + · have e : W = z1.withTrie (z1.trie.graftBelow z1.focus + (PathMap.sub ops z1.focusNode src.focusNode)) := by + simp only [W, hE, hS, hid, if_false, Bool.false_eq_true] + rw [e] + apply leaf_graft_ite z h _ _ hroot + intro b r; rw [hval, PM.valAt_sub, focusNode_eq_of_valueStep z h] + unfold Zip.subtractInto Zip.subtractIntoWithoutPrune + cases hz : z.val with + | none => + cases hs : src.val with + | none => exact tail z _ (valueStep_self z) hc (by rw [hz, hs]; rfl) _ _ _ + | some ov => exact tail z _ (valueStep_self z) hc (by rw [hz, hs]; rfl) _ _ _ + | some sv => + cases hs : src.val with + | none => exact tail z _ (valueStep_self z) hc (by rw [hz, hs]; rfl) _ _ _ + | some ov => + cases hr : (ops.psub sv ov).resolve sv ov with + | none => + simp only [hr] + exact tail _ _ (valueStep_removeVal z false) (prefixClosed_removeVal' z) + (by rw [hz, hs]; exact hr.symm) _ _ _ + | some v => + simp only [hr] + exact tail _ _ (valueStep_setVal z v) (prefixClosed_setVal' z v) + (by rw [hz, hs]; exact hr.symm) _ _ _ + +end Z + +namespace Z +variable (z : Zip V) + +theorem proj_graftSrcAt (src : Zip V) (k : Path) : + projZ (z.graftSrcAt src k) = (projZ z).graftSrcAt (projZ src) k := by + rw [Zip.graftSrcAt, proj_graftMap, PZip.graftSrcAt, projZ_trie, projZ_focus, proj_subtrie] + +theorem proj_removePrefix (n : Nat) : + (z.removePrefix n).1 = ((projZ z).removePrefix n).1 ∧ + projZ (z.removePrefix n).2 = ((projZ z).removePrefix n).2 := by + refine ⟨rfl, ?_⟩ + show projZ ((z.ascend n).2.graftMap z.makeMap) = ((projZ z).ascend n).2.graftMap (projZ z).makeMap + rw [proj_graftMap, projZ_makeMap]; rfl + +end Z + +/-! ## 4. Where the projection does not commute + +Each of these operations reads a dangling path, so no statement of the §3 shape +can hold for it. The witnesses are tries over `()`, checked by the kernel. -/ + +section Failures +set_option maxRecDepth 10000 + +/-- A map whose only location besides the root is the dangling path `[0]`. -/ +def danglingChild : PathMap Unit := (PathMap.empty : PathMap Unit).addPath [0] + +/-- `child_mask` counts a dangling child; the projection has none. -/ +theorem childMask_sees_dangling : + (Map.zipper danglingChild).childMask = [0] ∧ + (projZ (Map.zipper danglingChild)).childMask = [] := by decide + +/-- `restricting` with a source whose node holds only a dangling path: the crate's +model replaces the destination's subtrie with nothing, the pruned model sees an +empty source and leaves the destination alone. Values differ at `[0]`. -/ +theorem restricting_sees_dangling : + let z : Zip Unit := Map.zipper (Map.single [0] ()) + let src : Zip Unit := Map.zipper ((PathMap.empty : PathMap Unit).addPath [1]) + (z.restricting src).2.trie.valAt [0] = none ∧ + ((projZ z).restricting (projZ src)).2.trie.valAt [0] = some () := by decide + +/-- `meet_k_path_into 1` over `{0·5, 1·5}` plus a dangling `[2]`: the dangling +location is one more operand of the meet, and an empty one, so the meet is +empty. Without it the meet is `{5}`. (`PRUNED_FINDINGS.md` #6.) -/ +theorem meetKPathInto_sees_dangling : + let z : Zip Unit := Map.zipper (PathMap.mk' [([0, 5], ()), ([1, 5], ())] [[2]]) + (z.meetKPathInto unitOps 1 false).2.trie.valAt [5] = none ∧ + ((projZ z).meetKPathInto unitOps 1).2.trie.valAt [5] = some () := by decide + +/-- `take_map` at a focus with only a dangling path below it returns a map (with no +values); the pruned model returns `none`. The trie left behind agrees +(`Z.proj_takeMap`). -/ +theorem takeMap_fst_sees_dangling : + ((Map.zipper danglingChild).takeMap false).1.isSome = true ∧ + ((projZ (Map.zipper danglingChild)).takeMap).1 = none := by decide + +end Failures + +end Project +end PrunedModel diff --git a/lean/PrunedModel/Refine.lean b/lean/PrunedModel/Refine.lean new file mode 100644 index 00000000..78c136f4 --- /dev/null +++ b/lean/PrunedModel/Refine.lean @@ -0,0 +1,872 @@ +import PrunedModel.Write +import PrunedModel.Pointwise + +/-! +# What each write operation does to the trie + +Every write operation in `Write.lean` touches the trie only at and below the +focus. This file proves that, operation by operation, in one shape: + + (z.op …).2 = z.withTrie (z.trie.replaceAt z.focus M) + +where `replaceAt t f M` is `t` with everything at and below `f` replaced by the +map `M` (root value included), and `M` is named: `join ops z.makeMap m` for +`join_map_into`, `meet ops z.makeMap src.makeMap` for `meet_into`, and so on. + +That one equation says two things at once: + +* **frame** — nothing outside the focus's subtrie changes, and the cursor does + not move; +* **refinement** — read back at the focus (`makeMap`), the operation computes + `M`, a map-level operation on the two focused subtries. + +`Zippy.lean` builds the set algebra from these. Where `M` is *not* the obvious +set operation — `restrict` keeps the focus value, `join_into` ignores the +source's, `insert_prefix` leaves the focus value where it was — the difference +is in `M`, and `Zippy.lean` states it as a law of its own. + +Equality of values is decided by `ValOps.beq`, and two branches of the algebraic +operations return the zipper untouched when `beqT` says the result equals the +input. Those branches agree with the others only if `beq` is sound, so the +algebraic lemmas take `LawfulBeqOps ops`. `unitOps` and `u64Ops` both are. +-/ + +namespace PrunedModel + +open PathMapModel + +/-- `ValOps.beq` decides equality. -/ +def LawfulBeqOps {V : Type} (ops : ValOps V) : Prop := ∀ a b, ops.beq a b = true → a = b + +theorem unitOps_lawful : LawfulBeqOps unitOps := fun _ _ _ => rfl + +theorem u64Ops_lawful : LawfulBeqOps u64Ops := by + intro a b h + simpa [u64Ops] using h + +namespace PrunedMap + +variable {V : Type} + +/-! ## Replacing a subtrie -/ + +/-- `t` with everything at and below `f` replaced by `m`; `m`'s root value goes +to `f`. -/ +def replaceAt (t : PrunedMap V) (f : Path) (m : PrunedMap V) : PrunedMap V := + mk' ((t.removeAt f).entries ++ m.entries.map fun kv => (f ++ kv.1, kv.2)) + +theorem valAt_replaceAt (t : PrunedMap V) (f : Path) (m : PrunedMap V) (k : Path) : + (t.replaceAt f m).valAt k = + match Path.stripPrefix f k with + | some r => m.valAt r + | none => t.valAt k := by + rw [replaceAt, valAt_mk', lookup_append] + have hA : (t.removeAt f).entries.lookup k = (t.removeAt f).valAt k := rfl + rw [hA, valAt_removeAt, lookup_map_prepend, Path.isPrefixOf_eq_isSome_stripPrefix] + cases Path.stripPrefix f k <;> simp <;> rfl + +theorem valAt_replaceAt_append (t : PrunedMap V) (f : Path) (m : PrunedMap V) (r : Path) : + (t.replaceAt f m).valAt (f ++ r) = m.valAt r := by + rw [valAt_replaceAt, Path.stripPrefix_append] + +theorem valAt_replaceAt_of_not {t : PrunedMap V} {f : Path} {m : PrunedMap V} {k : Path} + (h : ∀ r, k ≠ f ++ r) : (t.replaceAt f m).valAt k = t.valAt k := by + rw [valAt_replaceAt, (Path.stripPrefix_eq_none f k).mpr h] + +/-- Replacing at the root replaces everything. -/ +theorem replaceAt_nil (t m : PrunedMap V) : t.replaceAt [] m = m := + ext fun k => by + show (t.replaceAt [] m).valAt k = m.valAt k + exact valAt_replaceAt_append t [] m k + +/-- Reading back what was written. -/ +theorem subtrie_replaceAt (t : PrunedMap V) (f : Path) (m : PrunedMap V) : + (t.replaceAt f m).subtrie f = m := + ext fun k => by + show ((t.replaceAt f m).subtrie f).valAt k = m.valAt k + rw [valAt_subtrie, valAt_replaceAt_append] + +/-- **The three-case check.** `t'` is `t` with `m` written at `f` iff they agree +away from `f`, at `f` (the root value), and strictly below `f` (the node). -/ +theorem eq_replaceAt {t t' : PrunedMap V} {f : Path} {m : PrunedMap V} + (hout : ∀ k, (∀ r, k ≠ f ++ r) → t'.valAt k = t.valAt k) + (hroot : t'.valAt f = m.valAt []) + (hbelow : ∀ b r, t'.valAt (f ++ b :: r) = m.valAt (b :: r)) : + t' = t.replaceAt f m := by + apply ext; intro k + show t'.valAt k = (t.replaceAt f m).valAt k + rw [valAt_replaceAt] + cases hs : Path.stripPrefix f k with + | none => exact hout k ((Path.stripPrefix_eq_none f k).mp hs) + | some r => + have := (Path.stripPrefix_eq_some f k r).mp hs; subst this + cases r with + | nil => simpa using hroot + | cons b r => exact hbelow b r + +/-- A path off `f`'s subtrie is not `f`. -/ +theorem ne_of_off {k f : Path} (h : ∀ r, k ≠ f ++ r) : k ≠ f := by + intro e; exact h [] (by simp [e]) + +/-- …and `graftBelow f` does not see it. -/ +theorem stripPrefix_off {k f : Path} (h : ∀ r, k ≠ f ++ r) : Path.stripPrefix f k = none := + (Path.stripPrefix_eq_none f k).mpr h + +/-- `x`'s root value over `n`'s node: what an operation that works on nodes — +and leaves the focus value alone — writes at the focus. -/ +def withRootOf (x n : PrunedMap V) : PrunedMap V := + mk' ((x.entries.filter fun kv => kv.1.isEmpty) ++ (n.entries.filter fun kv => !kv.1.isEmpty)) + +theorem valAt_withRootOf_nil (x n : PrunedMap V) : (withRootOf x n).valAt [] = x.valAt [] := by + rw [withRootOf, valAt_mk', lookup_append, lookup_filter_key (fun k => k.isEmpty), + lookup_filter_key (fun k => !k.isEmpty)] + simp; rfl + +theorem valAt_withRootOf_cons (x n : PrunedMap V) (b : UInt8) (r : Path) : + (withRootOf x n).valAt (b :: r) = n.valAt (b :: r) := by + rw [withRootOf, valAt_mk', lookup_append, lookup_filter_key (fun k => k.isEmpty), + lookup_filter_key (fun k => !k.isEmpty)] + simp; rfl + +/-- `validatedBy` reads only non-empty paths, so a root value is invisible to it. -/ +theorem validatedBy_congr {a b : PrunedMap V} (h : ∀ c r, a.valAt (c :: r) = b.valAt (c :: r)) + (q : Path) : validatedBy a q = validatedBy b q := by + apply Bool.eq_iff_iff.mpr + rw [validatedBy_iff, validatedBy_iff] + constructor + · rintro ⟨r, s, hr, hq, hv⟩ + cases r with + | nil => exact absurd rfl hr + | cons c r => exact ⟨c :: r, s, hr, hq, by rwa [← h]⟩ + · rintro ⟨r, s, hr, hq, hv⟩ + cases r with + | nil => exact absurd rfl hr + | cons c r => exact ⟨c :: r, s, hr, hq, by rwa [h]⟩ + +theorem validatedBy_empty (q : Path) : validatedBy (empty : PrunedMap V) q = false := by + cases h : validatedBy (empty : PrunedMap V) q with + | false => rfl + | true => + obtain ⟨r, s, _, _, hv⟩ := (validatedBy_iff _ _).mp h + simp at hv + +/-! ## `beqT` is equality, when `beq` is -/ + +private theorem eq_of_zip_all {ops : ValOps V} (hbeq : LawfulBeqOps ops) : + ∀ (l₁ l₂ : List (Path × V)), l₁.length = l₂.length → + (l₁.zip l₂).all (fun xy => xy.1.1 == xy.2.1 && ops.beq xy.1.2 xy.2.2) = true → l₁ = l₂ + | [], [], _, _ => rfl + | [], _ :: _, hl, _ => by simp at hl + | _ :: _, [], hl, _ => by simp at hl + | x :: xs, y :: ys, hl, h => by + simp only [List.zip_cons_cons, List.all_cons, Bool.and_eq_true, beq_iff_eq] at h + obtain ⟨⟨h1, h2⟩, h3⟩ := h + have := eq_of_zip_all hbeq xs ys (by simpa using hl) h3 + obtain ⟨xk, xv⟩ := x; obtain ⟨yk, yv⟩ := y + simp only at h1 h2 + rw [h1, hbeq _ _ h2, this] + +theorem eq_of_beqT {ops : ValOps V} (hbeq : LawfulBeqOps ops) {a b : PrunedMap V} + (h : beqT ops a b = true) : a = b := by + rw [beqT, Bool.and_eq_true, beq_iff_eq] at h + have he := eq_of_zip_all hbeq _ _ h.1 h.2 + exact ext fun k => by rw [he] + +end PrunedMap + +namespace PZip + +open PrunedMap + +variable {V : Type} (z : PZip V) + +/-! ## Reading at the focus -/ + +@[simp] theorem withTrie_trie (t : PrunedMap V) : (z.withTrie t).trie = t := rfl +@[simp] theorem withTrie_focus (t : PrunedMap V) : (z.withTrie t).focus = z.focus := rfl +@[simp] theorem withTrie_withTrie (t u : PrunedMap V) : + (z.withTrie t).withTrie u = z.withTrie u := rfl +@[simp] theorem withTrie_self : z.withTrie z.trie = z := rfl + +theorem valAt_makeMap (k : Path) : z.makeMap.valAt k = z.trie.valAt (z.focus ++ k) := + valAt_subtrie _ _ _ + +theorem makeMap_valAt_nil : z.makeMap.valAt [] = z.val := by + rw [valAt_makeMap, List.append_nil]; rfl + +theorem valAt_focusNode (k : Path) : + z.focusNode.valAt k = if k = [] then none else z.trie.valAt (z.focus ++ k) := by + rw [focusNode, valAt_removeVal, valAt_makeMap] + +theorem valAt_focusNode_cons (b : UInt8) (r : Path) : + z.focusNode.valAt (b :: r) = z.trie.valAt (z.focus ++ b :: r) := by + rw [valAt_focusNode]; simp + +theorem focusNode_isEmptyMap_iff : + z.focusNode.isEmptyMap = true ↔ ∀ b r, z.trie.valAt (z.focus ++ b :: r) = none := by + rw [isEmptyMap_iff] + constructor + · intro h b r; rw [← valAt_focusNode_cons]; exact h _ + · intro h k + cases k with + | nil => rw [valAt_focusNode]; simp + | cons b r => rw [valAt_focusNode_cons]; exact h b r + +theorem focusNodeIsEmpty_iff : + z.focusNodeIsEmpty = true ↔ ∀ b r, z.trie.valAt (z.focus ++ b :: r) = none := + belowIsEmpty_iff _ _ + +theorem focusNodeIsEmpty_eq : z.focusNodeIsEmpty = z.focusNode.isEmptyMap := by + apply Bool.eq_iff_iff.mpr + rw [focusNodeIsEmpty_iff, focusNode_isEmptyMap_iff] + +/-! ## The value at the focus -/ + +theorem setVal_eq (v : V) : + (z.setVal v).2 = z.withTrie (z.trie.replaceAt z.focus ((z.makeMap.setVal [] v).2)) := by + have h0 : (z.setVal v).2 = z.withTrie (z.trie.setVal z.focus v).2 := rfl + rw [h0] + congr 1 + apply eq_replaceAt + · intro k hk; rw [valAt_setVal, if_neg (ne_of_off hk)] + · rw [valAt_setVal, valAt_setVal]; simp + · intro b r + rw [valAt_setVal, valAt_setVal, valAt_makeMap] + simp + +theorem removeVal_eq : + (z.removeVal).2 = z.withTrie (z.trie.replaceAt z.focus ((z.makeMap.removeVal []).2)) := by + have key : z.trie.replaceAt z.focus ((z.makeMap.removeVal []).2) = (z.trie.removeVal z.focus).2 := by + symm + apply eq_replaceAt + · intro k hk; rw [valAt_removeVal, if_neg (ne_of_off hk)] + · rw [valAt_removeVal, valAt_removeVal]; simp + · intro b r + rw [valAt_removeVal, valAt_removeVal, valAt_makeMap] + simp + rw [key] + unfold removeVal + cases hv : z.val with + | some v => rfl + | none => + simp only + have : (z.trie.removeVal z.focus).2 = z.trie := by + apply ext; intro k + show (z.trie.removeVal z.focus).2.valAt k = z.trie.valAt k + rw [valAt_removeVal] + by_cases hk : k = z.focus + · subst hk; simp only [if_true]; exact hv.symm + · simp [hk] + rw [this]; rfl + +/-! ## Grafting -/ + +theorem graftMap_eq (m : PrunedMap V) : + z.graftMap m = z.withTrie (z.trie.replaceAt z.focus m) := by + show z.withTrie _ = _ + congr 1 + apply eq_replaceAt + · intro k hk + cases m.valAt [] <;> + simp [valAt_setVal, valAt_removeVal, valAt_graftBelow, ne_of_off hk, stripPrefix_off hk] + · cases hm : m.valAt [] <;> simp [valAt_setVal, valAt_removeVal] + · intro b r + have hne : z.focus ++ b :: r ≠ z.focus := by + intro h; have := congrArg List.length h; simp at this + cases m.valAt [] <;> + simp [valAt_setVal, valAt_removeVal, valAt_graftBelow, hne, Path.stripPrefix_append] + +theorem graft_eq (src : PZip V) : z.graft src = z.withTrie (z.trie.replaceAt z.focus src.makeMap) := + graftMap_eq z _ + +/-! ## The shared tail of the algebraic operations + +Every algebraic operation ends the same way: compute a node `r`, and either +graft it below the focus or — when `beqT` says it equals what is there — leave +the zipper alone. With a lawful `beq` the two branches agree, so each operation +is "graft `r`". -/ + +theorem graftBelow_focusNode : z.trie.graftBelow z.focus z.focusNode = z.trie := by + apply ext; intro k + show (z.trie.graftBelow z.focus z.focusNode).valAt k = z.trie.valAt k + rw [valAt_graftBelow] + cases hs : Path.stripPrefix z.focus k with + | none => rfl + | some r => + cases r with + | nil => rfl + | cons b r => + dsimp only + rw [valAt_focusNode_cons, (Path.stripPrefix_eq_some _ _ _).mp hs] + +theorem keep_eq_graft (z1 : PZip V) {r : PrunedMap V} (h : r = z1.focusNode) : + z1 = z1.withTrie (z1.trie.graftBelow z1.focus r) := by + rw [h, graftBelow_focusNode]; rfl + +theorem ite_beqT_graft {ops : ValOps V} (hbeq : LawfulBeqOps ops) (z1 : PZip V) (r : PrunedMap V) : + (if ((if beqT ops r z1.focusNode = true then AlgStatus.identity else AlgStatus.element) + == AlgStatus.identity) = true then z1 + else z1.withTrie (z1.trie.graftBelow z1.focus r)) = + z1.withTrie (z1.trie.graftBelow z1.focus r) := by + by_cases h : beqT ops r z1.focusNode = true + · simp only [h, if_true]; exact keep_eq_graft z1 (eq_of_beqT hbeq h) + · simp [h] + +theorem ite_nodeStatus_graft {ops : ValOps V} (hbeq : LawfulBeqOps ops) (z1 : PZip V) + (r : PrunedMap V) : + (if (nodeStatus ops z1.focusNode r == AlgStatus.identity) = true then z1 + else z1.withTrie (z1.trie.graftBelow z1.focus r)) = + z1.withTrie (z1.trie.graftBelow z1.focus r) := by + by_cases h : (nodeStatus ops z1.focusNode r == AlgStatus.identity) = true + · rw [if_pos h] + apply keep_eq_graft + unfold nodeStatus at h + by_cases he : r.isEmptyMap = true + · simp [he] at h + · by_cases hb : beqT ops r z1.focusNode = true + · exact eq_of_beqT hbeq hb + · simp [he, hb] at h + · rw [if_neg h] + +/-- Grafting below the focus of a zipper whose trie is `T`. -/ +theorem withTrie_graft_eq (T R : PrunedMap V) : + (z.withTrie T).withTrie ((z.withTrie T).trie.graftBelow (z.withTrie T).focus R) = + z.withTrie (T.graftBelow z.focus R) := rfl + +theorem removeVal_eq' : (z.removeVal).2 = z.withTrie (z.trie.removeVal z.focus).2 := by + unfold removeVal + cases hv : z.val with + | some v => rfl + | none => + simp only + have : (z.trie.removeVal z.focus).2 = z.trie := by + apply ext; intro k + show (z.trie.removeVal z.focus).2.valAt k = z.trie.valAt k + rw [valAt_removeVal] + by_cases hk : k = z.focus + · subst hk; simp only [if_true]; exact hv.symm + · simp [hk] + rw [this]; rfl + +theorem setVal_eq' (v : V) : (z.setVal v).2 = z.withTrie (z.trie.setVal z.focus v).2 := rfl + +end PZip + +/-! ## Facts about the operations on `Option V` that hold for every value type -/ + +namespace PrunedMap +variable {V : Type} (ops : ValOps V) + +@[simp] theorem joinVal_none_right (x : Option V) : joinVal ops x none = x := by + cases x <;> rfl +@[simp] theorem joinVal_none_left (x : Option V) : joinVal ops none x = x := rfl +@[simp] theorem meetVal_none_right (x : Option V) : meetVal ops x none = none := by + cases x <;> rfl +@[simp] theorem meetVal_none_left (x : Option V) : meetVal ops none x = none := rfl +@[simp] theorem subVal_none_right (x : Option V) : subVal ops x none = x := by + cases x <;> rfl +@[simp] theorem subVal_none_left (x : Option V) : subVal ops none x = none := rfl + +end PrunedMap + +namespace PZip +open PrunedMap +variable {V : Type} (z : PZip V) + +/-! ## Finishing an operation + +After the value step the zipper is `z.withTrie T`, where `T` differs from +`z.trie` at most at the focus. The node step then either keeps it or grafts a +node `R` below the focus. These two lemmas turn either ending into the +`replaceAt` form, given what `T` and `R` hold. -/ + +theorem finish_keep (T M : PrunedMap V) + (hout : ∀ k, (∀ r, k ≠ z.focus ++ r) → T.valAt k = z.trie.valAt k) + (hroot : T.valAt z.focus = M.valAt []) + (hbelow : ∀ b r, T.valAt (z.focus ++ b :: r) = M.valAt (b :: r)) : + z.withTrie T = z.withTrie (z.trie.replaceAt z.focus M) := by + congr 1 + exact eq_replaceAt hout hroot hbelow + +theorem stripPrefix_self (p : Path) : Path.stripPrefix p p = some [] := by + simpa using Path.stripPrefix_append p [] + +theorem finish_graft (T R M : PrunedMap V) + (hout : ∀ k, k ≠ z.focus → T.valAt k = z.trie.valAt k) + (hroot : T.valAt z.focus = M.valAt []) + (hbelow : ∀ b r, R.valAt (b :: r) = M.valAt (b :: r)) : + z.withTrie (T.graftBelow z.focus R) = z.withTrie (z.trie.replaceAt z.focus M) := by + apply finish_keep + · intro k hk + rw [valAt_graftBelow, stripPrefix_off hk] + exact hout k (ne_of_off hk) + · rw [valAt_graftBelow, stripPrefix_self] + exact hroot + · intro b r + rw [valAt_graftBelow, Path.stripPrefix_append] + exact hbelow b r + +/-! ## The algebraic operations -/ + +theorem joinMapInto_eq {ops : ValOps V} (hbeq : LawfulBeqOps ops) (m : PrunedMap V) : + (z.joinMapInto ops m).2 = z.withTrie (z.trie.replaceAt z.focus (join ops z.makeMap m)) := by + have tail : ∀ T : PrunedMap V, (∀ k, k ≠ z.focus → T.valAt k = z.trie.valAt k) → + T.valAt z.focus = joinVal ops z.val (m.valAt []) → + (if (m.removeVal []).2.isEmptyMap = true then z.withTrie T + else z.withTrie (T.graftBelow z.focus (join ops (z.withTrie T).focusNode (m.removeVal []).2))) + = z.withTrie (z.trie.replaceAt z.focus (join ops z.makeMap m)) := by + intro T hout hroot + have hroot' : T.valAt z.focus = (join ops z.makeMap m).valAt [] := by + rw [valAt_join, makeMap_valAt_nil, hroot] + split + · next hE => + have hmb : ∀ b r, m.valAt (b :: r) = none := fun b r => by + have := (isEmptyMap_iff _).mp hE (b :: r); rwa [valAt_removeVal, if_neg (by simp)] at this + apply finish_keep + · intro k hk; exact hout k (ne_of_off hk) + · exact hroot' + · intro b r; rw [valAt_join, valAt_makeMap, hmb, joinVal_none_right]; exact hout _ (by simp) + · apply finish_graft _ _ _ _ hout hroot' + intro b r + rw [valAt_join, valAt_join, valAt_focusNode_cons, valAt_removeVal, if_neg (by simp), valAt_makeMap] + simp only [withTrie_trie, withTrie_focus] + rw [hout _ (by simp)] + have offFocus : ∀ (v : V) k, k ≠ z.focus → (z.trie.setVal z.focus v).2.valAt k = z.trie.valAt k := + fun v k hk => by rw [valAt_setVal, if_neg hk] + have offFocus' : ∀ k, k ≠ z.focus → (z.trie.removeVal z.focus).2.valAt k = z.trie.valAt k := + fun k hk => by rw [valAt_removeVal, if_neg hk] + unfold joinMapInto + cases hz : z.val with + | none => + cases hm : m.valAt [] with + | none => + simp only [apply_ite Prod.snd] + rw [ite_beqT_graft hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hm]; exact hz) + | some mv => + simp only [apply_ite Prod.snd] + rw [ite_beqT_graft hbeq] + exact tail (z.trie.setVal z.focus mv).2 (offFocus mv) (by rw [valAt_setVal, if_pos rfl, hz, hm]; rfl) + | some sv => + cases hm : m.valAt [] with + | none => + simp only [apply_ite Prod.snd] + rw [ite_beqT_graft hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hm]; exact hz) + | some mv => + cases hr : (ops.pjoin sv mv).resolve sv mv with + | none => + simp only [apply_ite Prod.snd, hr] + rw [ite_beqT_graft hbeq, removeVal_eq'] + exact tail (z.trie.removeVal z.focus).2 offFocus' (by rw [valAt_removeVal, if_pos rfl, hz, hm]; exact hr.symm) + | some v => + simp only [apply_ite Prod.snd, hr] + rw [ite_beqT_graft hbeq] + exact tail (z.trie.setVal z.focus v).2 (offFocus v) (by rw [valAt_setVal, if_pos rfl, hz, hm]; exact hr.symm) + +/-! ### `removeBelow` at the focus -/ + +theorem isPrefixOf_off {k f : Path} (h : ∀ r, k ≠ f ++ r) : Path.isPrefixOf f k = false := by + rw [Path.isPrefixOf_eq_isSome_stripPrefix, stripPrefix_off h]; rfl + +theorem valAt_removeBelow_off (T : PrunedMap V) {f k : Path} (h : ∀ r, k ≠ f ++ r) : + (T.removeBelow f).valAt k = T.valAt k := by + rw [valAt_removeBelow, isPrefixOf_off h]; simp + +theorem valAt_removeBelow_self (T : PrunedMap V) (f : Path) : + (T.removeBelow f).valAt f = T.valAt f := by + rw [valAt_removeBelow]; simp + +theorem valAt_removeBelow_cons (T : PrunedMap V) (f : Path) (b : UInt8) (r : Path) : + (T.removeBelow f).valAt (f ++ b :: r) = none := by + rw [valAt_removeBelow, if_pos ⟨(Path.isPrefixOf_iff _ _).mpr ⟨_, rfl⟩, by simp⟩] + +theorem focus_cons_ne (b : UInt8) (r : Path) : z.focus ++ b :: r ≠ z.focus := by simp + +theorem ite_beqT_graft' {ops : ValOps V} (hbeq : LawfulBeqOps ops) (z1 : PZip V) (r : PrunedMap V) : + (if beqT ops r z1.focusNode = true then z1 + else z1.withTrie (z1.trie.graftBelow z1.focus r)) = + z1.withTrie (z1.trie.graftBelow z1.focus r) := by + by_cases h : beqT ops r z1.focusNode = true + · rw [if_pos h]; exact keep_eq_graft z1 (eq_of_beqT hbeq h) + · rw [if_neg h] + +theorem meetInto_eq {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : PZip V) : + (z.meetInto ops src).2 = z.withTrie (z.trie.replaceAt z.focus (meet ops z.makeMap src.makeMap)) := by + have tail : ∀ T : PrunedMap V, (∀ k, k ≠ z.focus → T.valAt k = z.trie.valAt k) → + T.valAt z.focus = meetVal ops z.val src.val → + (if (z.withTrie T).focusNode.isEmptyMap = true then z.withTrie T + else if src.focusNode.isEmptyMap = true then z.withTrie (T.removeBelow z.focus) + else z.withTrie (T.graftBelow z.focus (meet ops (z.withTrie T).focusNode src.focusNode))) + = z.withTrie (z.trie.replaceAt z.focus (meet ops z.makeMap src.makeMap)) := by + intro T hout hroot + have hroot' : T.valAt z.focus = (meet ops z.makeMap src.makeMap).valAt [] := by + rw [valAt_meet, makeMap_valAt_nil, makeMap_valAt_nil, hroot] + have hT : ∀ b r, T.valAt (z.focus ++ b :: r) = z.trie.valAt (z.focus ++ b :: r) := + fun b r => hout _ (focus_cons_ne z b r) + split + · next hE => + apply finish_keep + · intro k hk; exact hout k (ne_of_off hk) + · exact hroot' + · intro b r + have h0 := (focusNode_isEmptyMap_iff _).mp hE b r + simp only [withTrie_trie, withTrie_focus] at h0 + rw [valAt_meet, valAt_makeMap, ← hT, h0, meetVal_none_left] + · split + · next _ hE => + apply finish_keep + · intro k hk; rw [valAt_removeBelow_off _ hk]; exact hout k (ne_of_off hk) + · rw [valAt_removeBelow_self]; exact hroot' + · intro b r + rw [valAt_removeBelow_cons, valAt_meet, valAt_makeMap src, + (focusNode_isEmptyMap_iff src).mp hE b r, meetVal_none_right] + · apply finish_graft _ _ _ _ hout hroot' + intro b r + rw [valAt_meet, valAt_meet, valAt_focusNode_cons, valAt_focusNode_cons, valAt_makeMap, + valAt_makeMap] + simp only [withTrie_trie, withTrie_focus]; rw [hT] + have offFocus : ∀ (v : V) k, k ≠ z.focus → (z.trie.setVal z.focus v).2.valAt k = z.trie.valAt k := + fun v k hk => by rw [valAt_setVal, if_neg hk] + have offFocus' : ∀ k, k ≠ z.focus → (z.trie.removeVal z.focus).2.valAt k = z.trie.valAt k := + fun k hk => by rw [valAt_removeVal, if_neg hk] + unfold meetInto + cases hz : z.val with + | none => + cases hs : src.val with + | none => + simp only [apply_ite Prod.snd] + rw [ite_nodeStatus_graft hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hs]; exact hz) + | some ov => + simp only [apply_ite Prod.snd] + rw [ite_nodeStatus_graft hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hs]; exact hz) + | some sv => + cases hs : src.val with + | none => + simp only [apply_ite Prod.snd] + rw [ite_nodeStatus_graft hbeq, removeVal_eq'] + exact tail (z.trie.removeVal z.focus).2 offFocus' + (by rw [valAt_removeVal, if_pos rfl, hz, hs]; rfl) + | some ov => + cases hr : (ops.pmeet sv ov).resolve sv ov with + | none => + simp only [apply_ite Prod.snd, hr] + rw [ite_nodeStatus_graft hbeq, removeVal_eq'] + exact tail (z.trie.removeVal z.focus).2 offFocus' + (by rw [valAt_removeVal, if_pos rfl, hz, hs]; exact hr.symm) + | some v => + simp only [apply_ite Prod.snd, hr] + rw [ite_nodeStatus_graft hbeq] + exact tail (z.trie.setVal z.focus v).2 (offFocus v) + (by rw [valAt_setVal, if_pos rfl, hz, hs]; exact hr.symm) + +theorem subtractInto_eq {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : PZip V) : + (z.subtractInto ops src).2 = z.withTrie (z.trie.replaceAt z.focus (sub ops z.makeMap src.makeMap)) := by + have tail : ∀ T : PrunedMap V, (∀ k, k ≠ z.focus → T.valAt k = z.trie.valAt k) → + T.valAt z.focus = subVal ops z.val src.val → + (if src.focusNode.isEmptyMap = true then z.withTrie T + else if (z.withTrie T).focusNode.isEmptyMap = true then z.withTrie T + else z.withTrie (T.graftBelow z.focus (sub ops (z.withTrie T).focusNode src.focusNode))) + = z.withTrie (z.trie.replaceAt z.focus (sub ops z.makeMap src.makeMap)) := by + intro T hout hroot + have hroot' : T.valAt z.focus = (sub ops z.makeMap src.makeMap).valAt [] := by + rw [valAt_sub, makeMap_valAt_nil, makeMap_valAt_nil, hroot] + have hT : ∀ b r, T.valAt (z.focus ++ b :: r) = z.trie.valAt (z.focus ++ b :: r) := + fun b r => hout _ (focus_cons_ne z b r) + split + · next hE => + apply finish_keep + · intro k hk; exact hout k (ne_of_off hk) + · exact hroot' + · intro b r + rw [valAt_sub, valAt_makeMap, valAt_makeMap src, (focusNode_isEmptyMap_iff src).mp hE b r, + subVal_none_right, hT] + · split + · next _ hE => + apply finish_keep + · intro k hk; exact hout k (ne_of_off hk) + · exact hroot' + · intro b r + have h0 := (focusNode_isEmptyMap_iff _).mp hE b r + simp only [withTrie_trie, withTrie_focus] at h0 + rw [valAt_sub, valAt_makeMap, ← hT, h0, subVal_none_left] + · apply finish_graft _ _ _ _ hout hroot' + intro b r + rw [valAt_sub, valAt_sub, valAt_focusNode_cons, valAt_focusNode_cons, valAt_makeMap, + valAt_makeMap] + simp only [withTrie_trie, withTrie_focus]; rw [hT] + have offFocus : ∀ (v : V) k, k ≠ z.focus → (z.trie.setVal z.focus v).2.valAt k = z.trie.valAt k := + fun v k hk => by rw [valAt_setVal, if_neg hk] + have offFocus' : ∀ k, k ≠ z.focus → (z.trie.removeVal z.focus).2.valAt k = z.trie.valAt k := + fun k hk => by rw [valAt_removeVal, if_neg hk] + unfold subtractInto + cases hz : z.val with + | none => + cases hs : src.val with + | none => + simp only [apply_ite Prod.snd] + rw [ite_nodeStatus_graft hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hs]; exact hz) + | some ov => + simp only [apply_ite Prod.snd] + rw [ite_nodeStatus_graft hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hs]; exact hz) + | some sv => + cases hs : src.val with + | none => + simp only [apply_ite Prod.snd] + rw [ite_nodeStatus_graft hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hs]; exact hz) + | some ov => + cases hr : (ops.psub sv ov).resolve sv ov with + | none => + simp only [apply_ite Prod.snd, hr] + rw [ite_nodeStatus_graft hbeq, removeVal_eq'] + exact tail (z.trie.removeVal z.focus).2 offFocus' + (by rw [valAt_removeVal, if_pos rfl, hz, hs]; exact hr.symm) + | some v => + simp only [apply_ite Prod.snd, hr] + rw [ite_nodeStatus_graft hbeq] + exact tail (z.trie.setVal z.focus v).2 (offFocus v) + (by rw [valAt_setVal, if_pos rfl, hz, hs]; exact hr.symm) + +/-- `join_into` writes the join of the two subtries, focus values included. -/ +theorem joinInto_eq {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : PZip V) : + (z.joinInto ops src).2 = z.withTrie (z.trie.replaceAt z.focus (join ops z.makeMap src.makeMap)) := by + have tail : ∀ T : PrunedMap V, (∀ k, k ≠ z.focus → T.valAt k = z.trie.valAt k) → + T.valAt z.focus = joinVal ops z.val src.val → + (if src.focusNode.isEmptyMap = true then z.withTrie T + else z.withTrie (T.graftBelow z.focus (join ops (z.withTrie T).focusNode src.focusNode))) + = z.withTrie (z.trie.replaceAt z.focus (join ops z.makeMap src.makeMap)) := by + intro T hout hroot + have hroot' : T.valAt z.focus = (join ops z.makeMap src.makeMap).valAt [] := by + rw [valAt_join, makeMap_valAt_nil, makeMap_valAt_nil, hroot] + split + · next hE => + apply finish_keep + · intro k hk; exact hout k (ne_of_off hk) + · exact hroot' + · intro b r + rw [valAt_join, valAt_makeMap, valAt_makeMap src, (focusNode_isEmptyMap_iff src).mp hE b r, + joinVal_none_right] + exact hout _ (focus_cons_ne z b r) + · apply finish_graft _ _ _ _ hout hroot' + intro b r + rw [valAt_join, valAt_join, valAt_focusNode_cons, valAt_focusNode_cons, valAt_makeMap, + valAt_makeMap] + simp only [withTrie_trie, withTrie_focus] + rw [hout _ (focus_cons_ne z b r)] + have offFocus : ∀ (v : V) k, k ≠ z.focus → (z.trie.setVal z.focus v).2.valAt k = z.trie.valAt k := + fun v k hk => by rw [valAt_setVal, if_neg hk] + have offFocus' : ∀ k, k ≠ z.focus → (z.trie.removeVal z.focus).2.valAt k = z.trie.valAt k := + fun k hk => by rw [valAt_removeVal, if_neg hk] + unfold joinInto + cases hz : z.val with + | none => + cases hs : src.val with + | none => + simp only [ite_beqT_graft' hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hs]; exact hz) + | some mv => + simp only [ite_beqT_graft' hbeq] + exact tail (z.trie.setVal z.focus mv).2 (offFocus mv) (by rw [valAt_setVal, if_pos rfl, hz, hs]; rfl) + | some sv => + cases hs : src.val with + | none => + simp only [ite_beqT_graft' hbeq] + exact tail z.trie (fun _ _ => rfl) (by rw [hz, hs]; exact hz) + | some mv => + cases hr : (ops.pjoin sv mv).resolve sv mv with + | none => + simp only [hr, ite_beqT_graft' hbeq, removeVal_eq'] + exact tail (z.trie.removeVal z.focus).2 offFocus' (by rw [valAt_removeVal, if_pos rfl, hz, hs]; exact hr.symm) + | some v => + simp only [hr, ite_beqT_graft' hbeq] + exact tail (z.trie.setVal z.focus v).2 (offFocus v) (by rw [valAt_setVal, if_pos rfl, hz, hs]; exact hr.symm) + +/-- `restrict` is `PathMap::restrict` on the two subtries: a source focus value +keeps everything, and otherwise a path is kept when a *non-empty* prefix of it is +valued in the source — so the destination's focus value goes. -/ +theorem restrict_eq {ops : ValOps V} (hbeq : LawfulBeqOps ops) (src : PZip V) : + (z.restrict ops src).2 = z.withTrie (z.trie.replaceAt z.focus + (if src.val.isSome then z.makeMap else restrictBelowRoot z.makeMap src.makeMap)) := by + unfold restrict + by_cases hs : src.val.isSome = true + · simp only [hs, if_true] + apply finish_keep + · intro _ _; rfl + · rw [makeMap_valAt_nil]; rfl + · intro b r; rw [valAt_makeMap] + · simp only [hs, Bool.false_eq_true, if_false] + have hv : ∀ q, validatedBy src.focusNode q = validatedBy src.makeMap q := + validatedBy_congr (fun c r => by rw [valAt_focusNode_cons, valAt_makeMap]) + have hroot : (z.trie.removeVal z.focus).2.valAt z.focus = + (restrictBelowRoot z.makeMap src.makeMap).valAt [] := by + rw [valAt_removeVal, if_pos rfl, valAt_restrictBelowRoot]; rfl + have hout : ∀ k, k ≠ z.focus → (z.trie.removeVal z.focus).2.valAt k = z.trie.valAt k := + fun k hk => by rw [valAt_removeVal, if_neg hk] + rw [removeVal_eq'] + simp only [apply_ite Prod.snd] + rw [ite_nodeStatus_graft hbeq] + split + · next hE => + show z.withTrie ((z.trie.removeVal z.focus).2.removeBelow z.focus) = _ + apply finish_keep + · intro k hk; rw [valAt_removeBelow_off _ hk] + exact hout k (ne_of_off hk) + · rw [valAt_removeBelow_self]; exact hroot + · intro b r + rw [valAt_removeBelow_cons, valAt_restrictBelowRoot, ← hv, + validatedBy_congr (b := empty) (fun c r => (isEmptyMap_iff _).mp hE _), validatedBy_empty] + rfl + · split + · next _ hE => + apply finish_keep _ _ _ (fun k hk => hout k (ne_of_off hk)) hroot + intro b r + have h0 := (focusNode_isEmptyMap_iff _).mp hE b r + simp only [withTrie_trie, withTrie_focus] at h0 + rw [valAt_restrictBelowRoot, valAt_makeMap, ← hout _ (focus_cons_ne z b r), h0] + split <;> rfl + · rw [withTrie_graft_eq] + apply finish_graft _ _ _ _ hout hroot + intro b r + rw [valAt_restrictBelowRoot, valAt_restrictBelowRoot, hv, valAt_focusNode_cons, valAt_makeMap] + simp only [withTrie_trie, withTrie_focus] + rw [hout _ (focus_cons_ne z b r)] + +theorem removeBranches_eq : + (z.removeBranches).2 = z.withTrie (z.trie.replaceAt z.focus (withRootOf z.makeMap empty)) := by + apply finish_keep + · intro k hk; rw [valAt_removeBelow_off _ hk] + · rw [valAt_removeBelow_self, valAt_withRootOf_nil, makeMap_valAt_nil]; rfl + · intro b r; rw [valAt_removeBelow_cons, valAt_withRootOf_cons]; rfl + +/-- Where the focus does not exist, nothing lies at or below it. -/ +theorem valAt_of_not_pathExists (h : z.pathExists = false) (r : Path) : + z.trie.valAt (z.focus ++ r) = none := by + cases hv : z.trie.valAt (z.focus ++ r) with + | none => rfl + | some v => + exfalso + have hmem : z.focus ++ r ∈ z.trie.keys := + mem_keys_of_lookup_isSome (l := z.trie.entries) + (show (z.trie.entries.lookup (z.focus ++ r)).isSome = true by + rw [show z.trie.entries.lookup (z.focus ++ r) = some v from hv]; rfl) + have he : z.trie.pathExists z.focus = true := by + simp only [PrunedMap.pathExists, Bool.or_eq_true, List.any_eq_true] + exact Or.inr ⟨_, hmem, (Path.isPrefixOf_iff _ _).mpr ⟨r, rfl⟩⟩ + rw [show z.pathExists = z.trie.pathExists z.focus from rfl, he] at h + cases h + +theorem prepend_nil (m : PrunedMap V) : m.prepend [] = m := by + apply ext; intro k + show (m.prepend []).valAt k = m.valAt k + rw [valAt_prepend] + have := Path.stripPrefix_append [] k + simp only [List.nil_append] at this + rw [this] + +/-- `insert_prefix` moves the whole subtrie, focus value included. -/ +theorem insertPrefix_eq (pre : Path) : + (z.insertPrefix pre).2 = z.withTrie (z.trie.replaceAt z.focus (z.makeMap.prepend pre)) := by + unfold insertPrefix + by_cases hx : z.pathExists = true + · simp only [hx, Bool.not_true, Bool.false_eq_true, if_false] + by_cases hp : pre.isEmpty = true + · simp only [hp, if_true] + rw [List.isEmpty_iff.mp hp, prepend_nil] + apply finish_keep + · intro _ _; rfl + · rw [makeMap_valAt_nil]; rfl + · intro b r; rw [valAt_makeMap] + · simp only [hp, Bool.false_eq_true, if_false] + exact graftMap_eq z _ + · have hx' : z.pathExists = false := by simpa using hx + simp only [hx', Bool.not_false, if_true] + have hnone : ∀ r, z.trie.valAt (z.focus ++ r) = none := valAt_of_not_pathExists z hx' + apply finish_keep + · intro _ _; rfl + · rw [valAt_prepend] + have := hnone []; rw [List.append_nil] at this; rw [this] + split <;> first | rfl | (rw [valAt_makeMap, hnone]) + · intro b r + rw [valAt_prepend, hnone] + split <;> first | rfl | (rw [valAt_makeMap, hnone]) + +/-- `meet_2` writes the meet of the two sources' subtries, focus values included. -/ +theorem meet2_eq {ops : ValOps V} (a b : PZip V) : + (z.meet2 ops a b).2 = z.withTrie (z.trie.replaceAt z.focus (meet ops a.makeMap b.makeMap)) := + graftMap_eq z _ + +/-- `join_k_path_into k` writes `dropHead` of the subtrie. -/ +theorem joinKPathInto_eq {ops : ValOps V} (k : Nat) : + (z.joinKPathInto ops k).2 = + if k == 0 then z else z.withTrie (z.trie.replaceAt z.focus (dropHead ops z.makeMap k)) := by + unfold joinKPathInto + split + · rfl + · exact graftMap_eq z _ + +/-- `meet_k_path_into k` grafts the meet of the subtries `k` bytes down, or the +empty map when there are none. -/ +theorem meetKPathInto_snd {ops : ValOps V} (k : Nat) : + (z.meetKPathInto ops k).2 = z.graftMap + ((((z.trie.subtrie z.focus).kPaths k).foldl (meetStep ops z.trie z.focus) none).getD empty) := by + unfold meetKPathInto + dsimp only + cases ((z.trie.subtrie z.focus).kPaths k).foldl (meetStep ops z.trie z.focus) none <;> rfl + +/-- `remove_prefix n` ascends, then grafts what was the subtrie at the focus. -/ +theorem removePrefix_snd (n : Nat) : + (z.removePrefix n).2 = (z.ascend n).2.graftMap z.makeMap := rfl + +/-- `take_map` removes the focus's subtrie, value included… -/ +theorem takeMap_snd : (z.takeMap).2 = z.withTrie (z.trie.replaceAt z.focus empty) := by + apply finish_keep + · intro k hk + show (z.trie.removeAt z.focus).valAt k = _ + rw [valAt_removeAt, isPrefixOf_off hk]; rfl + · show (z.trie.removeAt z.focus).valAt z.focus = _ + rw [valAt_removeAt, if_pos ((Path.isPrefixOf_iff _ _).mpr ⟨[], by simp⟩)]; rfl + · intro b r + show (z.trie.removeAt z.focus).valAt _ = _ + rw [valAt_removeAt, if_pos ((Path.isPrefixOf_iff _ _).mpr ⟨_, rfl⟩)]; rfl + +/-- …and returns it: `make_map` before the removal, or `none` when there was +nothing there. -/ +theorem takeMap_fst : (z.takeMap).1 = if z.makeMap.isEmptyMap then none else some z.makeMap := by + have htaken : (match z.val with + | some v => (z.focusNode.setVal [] v).2 + | none => z.focusNode) = z.makeMap := by + apply ext; intro k + show PrunedMap.valAt _ k = z.makeMap.valAt k + cases hv : z.val with + | some v => + simp only + rw [valAt_setVal, valAt_focusNode, valAt_makeMap] + by_cases hk : k = [] <;> simp [hk]; exact hv.symm + | none => + simp only + rw [valAt_focusNode, valAt_makeMap] + by_cases hk : k = [] <;> simp [hk]; exact hv.symm + have hemp : (z.focusNode.isEmptyMap && z.val.isNone) = z.makeMap.isEmptyMap := by + apply Bool.eq_iff_iff.mpr + rw [Bool.and_eq_true, focusNode_isEmptyMap_iff, isEmptyMap_iff, Option.isNone_iff_eq_none] + constructor + · rintro ⟨h1, h2⟩ k + cases k with + | nil => rw [makeMap_valAt_nil]; exact h2 + | cons b r => rw [valAt_makeMap]; exact h1 b r + · intro h + exact ⟨fun b r => by rw [← valAt_makeMap]; exact h _, by rw [← makeMap_valAt_nil]; exact h _⟩ + unfold takeMap + simp only + rw [hemp] + by_cases h : z.makeMap.isEmptyMap = true + · rw [if_pos h, if_pos h] + · rw [if_neg h, if_neg h]; exact congrArg some htaken + +end PZip +end PrunedModel diff --git a/lean/PrunedModel/Spec.lean b/lean/PrunedModel/Spec.lean new file mode 100644 index 00000000..ff5beab7 --- /dev/null +++ b/lean/PrunedModel/Spec.lean @@ -0,0 +1,176 @@ +import PrunedModel.Write + +/-! +# What this model claims + +`PathMapModel/Spec.lean` has to say, operation by operation, which valueless +locations survive it. This model has a single claim instead, and everything +else is a consequence. + +**There is no dangling path.** A location that exists with nothing below it +carries a value — not as an invariant the constructors maintain, but because +existence is *defined* as "some key runs through here". `no_dangling` is the +proof, and its shortness is the measure of what dropping the `Option` buys. + +The consequence the fuzzer trades on: `prune_path` has nothing to do, so the +crate must report `0` for it on any trie built from this subset. Each time it +does not, some operation in the subset leaked a location that leads nowhere. + +The `#guard`s at the end are the executable half — small concrete tries run +through the definitions and checked at elaboration time. They catch the class +of mistake that type-checks right through: a swapped argument order, a `take` +that should have been a `drop`. +-/ + +namespace PrunedModel +namespace PrunedMap + +open PathMapModel + +variable {V : Type} + +/-! ## Keys and lookup -/ + +/-- Every path is a prefix of itself. -/ +theorem isPrefixOf_self : ∀ p : Path, (p ≼ p) = true + | [] => rfl + | _ :: as => by simp [Path.isPrefixOf, isPrefixOf_self as] + +/-- A key is bound: `lookup` finds whatever `map (·.1)` saw. -/ +theorem lookup_isSome_of_mem_keys {l : List (Path × V)} {p : Path} + (h : p ∈ l.map (·.1)) : (l.lookup p).isSome = true := by + obtain ⟨kv, hmem, heq⟩ := List.mem_map.mp h + exact List.lookup_isSome_iff.mpr ⟨kv, hmem, by simp [heq]⟩ + +/-- …and conversely, `lookup` only succeeds on a key. -/ +theorem mem_keys_of_lookup_isSome {l : List (Path × V)} {p : Path} + (h : (l.lookup p).isSome = true) : p ∈ l.map (·.1) := by + obtain ⟨kv, hmem, hb⟩ := List.lookup_isSome_iff.mp h + exact List.mem_map.mpr ⟨kv, hmem, (eq_of_beq hb).symm⟩ + +/-- Holding a value entails existing. -/ +theorem pathExists_of_valAt {t : PrunedMap V} {p : Path} {v : V} + (h : t.valAt p = some v) : t.pathExists p = true := by + have hmem : p ∈ t.keys := + mem_keys_of_lookup_isSome (l := t.entries) (p := p) + (show (t.entries.lookup p).isSome = true by + rw [show t.entries.lookup p = some v from h]; rfl) + cases hp : p.isEmpty with + | true => simp [pathExists, hp] + | false => + simp only [pathExists, hp, Bool.false_or, List.any_eq_true] + exact ⟨p, hmem, isPrefixOf_self p⟩ + +/-! ## The claim -/ + +/-- **No dangling paths.** A location that some key runs through, and that has +nothing strictly below it, carries a value. + +`pathExists` admits the root unconditionally — `PathMap::new().read_zipper()` +reports `path_exists() == true`, and the root of an empty trie is the one +location that exists without leading anywhere — so the hypothesis here is its +other disjunct. Together with "nothing strictly below `p`", the key running +through `p` can only be `p` itself. -/ +theorem no_dangling {t : PrunedMap V} {p : Path} + (hx : t.keys.any (fun k => p ≼ k) = true) (hb : t.belowIsEmpty p = true) : + (t.valAt p).isSome = true := by + obtain ⟨k, hk, hpk⟩ := List.any_eq_true.mp hx + have hkp : k == p := by simpa [hpk] using (List.all_eq_true.mp hb) k hk + exact lookup_isSome_of_mem_keys (by simpa [keys, eq_of_beq hkp] using hk) + +/-- Hence `prune_path` has nothing to prune, and reports `0`… -/ +theorem prunePath_eq_zero (t : PrunedMap V) (p : Path) : (t.prunePath p).1 = 0 := rfl + +/-- …and leaves the trie alone. -/ +theorem prunePath_id (t : PrunedMap V) (p : Path) : (t.prunePath p).2 = t := rfl + +/-- The empty trie has no values, so `is_empty` and "no keys" coincide. -/ +theorem isEmptyMap_empty : (empty : PrunedMap V).isEmptyMap = true := rfl + +/-- The root of the empty trie still exists — the one location that does. -/ +theorem pathExists_root (t : PrunedMap V) : t.pathExists [] = true := by + simp [pathExists] + +/-! ## Executable checks + +Concrete tries, run through the definitions at elaboration time. `t1` branches +at the root and carries a value at an interior location; `t2` is a single chain +beside a single leaf, which is the shape every dangling-path question is about. -/ + +section Guards + +private def t1 : PrunedMap UInt64 := mk' [([0, 1], 7), ([0], 3), ([2], 9)] +private def t2 : PrunedMap UInt64 := mk' [([0, 1, 2], 5), ([3], 7)] + +-- Canonical form: sorted depth-first, so a prefix precedes its extensions. +#guard t1.keys == [[0], [0, 1], [2]] +#guard t1.paths == [[], [0], [0, 1], [2]] +#guard t1.valAt [0] == some 3 +#guard t1.valAt [1] == none +#guard t1.valCount [] == 3 && t1.valCount [0] == 2 +#guard t1.childMask [] == ([0, 2] : List UInt8) +#guard t1.childCount [0] == 1 && t1.childCount [0, 1] == 0 + +-- Existence is the prefix closure of the keys, and nothing more. +#guard t1.pathExists [0, 1] && !t1.pathExists [1] && !t1.pathExists [0, 1, 2] +#guard t2.pathExists [0] && t2.pathExists [0, 1] && !t2.pathExists [0, 2] + +-- `no_dangling`, concretely: the one location with nothing below it is valued. +#guard t1.belowIsEmpty [0, 1] && (t1.valAt [0, 1]).isSome + +-- Removing a value removes the chain that existed only to reach it… +#guard (t2.removeVal [0, 1, 2]).2.keys == [[3]] +#guard !(t2.removeVal [0, 1, 2]).2.pathExists [0] +-- …but not a location some other key still runs through. +#guard (t1.removeVal [0]).2.keys == [[0, 1], [2]] && (t1.removeVal [0]).2.pathExists [0] + +-- `set_val` reports the value it replaced. +#guard (t1.setVal [0] 11).1 == some 3 && (t1.setVal [0] 11).2.valAt [0] == some 11 +#guard (t1.setVal [5] 11).1 == none && (t1.setVal [5] 11).2.keys == [[0], [0, 1], [2], [5]] + +-- Grafting an empty node below a *valued* location keeps the location… +#guard (t1.graftBelow [0] empty).keys == [[0], [2]] +-- …and below a valueless one takes the whole chain with it. This is the +-- model's central disagreement with `pathmap` 0.4.0, which leaves `[0]` and +-- `[0,1]` behind as dangling paths. +#guard (t2.graftBelow [0, 1] empty).keys == [[3]] +#guard !(t2.graftBelow [0, 1] empty).pathExists [0] + +-- Sub-tries carry the focus value as their root value. +#guard (t1.subtrie [0]).keys == [[], [1]] && (t1.subtrie [0]).valAt [] == some 3 +#guard (t1.subtrie [9]).isEmptyMap + +-- Algebra. `u64`'s `psubtract` annihilates on equal values, and its `pjoin` +-- and `pmeet` are left-biased projections. +#guard (sub u64Ops t1 t1).isEmptyMap +#guard (sub u64Ops t1 (mk' [([0], 3)])).keys == [[0, 1], [2]] +#guard (meet u64Ops t1 t1).keys == t1.keys +#guard (meet u64Ops t1 (mk' [([0], 99)])).entries == [([0], 3)] +#guard (join u64Ops t1 empty).entries == t1.entries +#guard (join u64Ops (mk' [([0], 1)]) (mk' [([2], 4)])).entries == [([0], 1), ([2], 4)] + +-- `prestrict` validates on a non-empty prefix only, so the root value of the +-- filter is invisible at node level. +#guard (restrictBelowRoot t1 (mk' [([0], 1)])).keys == [[0], [0, 1]] +#guard (restrictBelowRoot t1 (mk' [([], 1)])).isEmptyMap + +-- `drop_head` keeps the values sitting at depth exactly `k`: `[3]` is at depth +-- 1, so its value becomes the root value of the joined map. +#guard (dropHead u64Ops t2 1).entries == [([], 7), ([1, 2], 5)] +#guard (dropHead u64Ops t2 0).entries == t2.entries + +-- A write zipper at the map root, as the fuzzer builds it. +private def z2 : PZip UInt64 := { trie := t2, root := [], path := [0, 1] } + +-- `remove_branches` at a valueless focus takes the focus with it: it has no +-- value of its own and now nothing below, so it stops existing. +#guard (PZip.removeBranches z2).1 && (PZip.removeBranches z2).2.trie.keys == [[3]] +-- Nothing to prune afterwards, which is what the crate is checked against. +#guard (PZip.prunePath (PZip.removeBranches z2).2).1 == 0 +-- `remove_val` at a location with no value is a no-op, flag and all. +#guard (PZip.removeVal z2).1 == none && (PZip.removeVal z2).2.trie.entries == t2.entries + +end Guards + +end PrunedMap +end PrunedModel diff --git a/lean/PrunedModel/Write.lean b/lean/PrunedModel/Write.lean new file mode 100644 index 00000000..1b7e4435 --- /dev/null +++ b/lean/PrunedModel/Write.lean @@ -0,0 +1,419 @@ +import PrunedModel.Zipper + +/-! +# The write zipper, restricted to the dangling-path-free subset + +Two invariants shape the whole API: + +1. **A subtrie includes the value at its root.** The subtrie at a zipper's + focus therefore includes the focus value, and every operation on subtries — + `graft`, `graft_map`, `make_map`, `take_map`, `join_into`, `join_map_into`, + `meet_into`, `subtract_into`, `meet_2`, `restrict`, `insert_prefix`, + `remove_prefix`, `join_k_path_into` — treats it as part of the subtrie. This + is `focus_value_consistency` (issue #104); the node-level primitives + underneath still see only what lies strictly below a location. + +2. **There is no prune flag.** In `PathMapModel` every mutating operation takes + one, because a write leaves a dangling path behind unless it is passed — and + even then the flag's effect is a function of where the internal node boundary + happens to fall (`PathMapModel/Fuzz.lean` therefore always passes `false` and + compares nothing). Here existence is derived from the keys, so removing the + last value under a chain removes the chain, with nothing to opt into. The + crate is driven with `prune = true` and must agree. + +## What is missing, and why + +* **`create_path`** — its entire purpose is to make a location that carries no + value. It cannot be modelled here and is not in the fuzzer's table. +* **`remove_val(false)`** — the non-pruning removal leaves the chain behind. + Only `remove_val(true)` is in the subset. +* **A write zipper below the map root** — see `PrunedModel/Zipper.lean`. + +Everything else in `ZipperWriting` is here. Several of those operations *can* +still leave a dangling path in `pathmap` 0.4.0 — `graft` of an empty source is +the clearest case — and the model says they must not. Those divergences are the +output this model exists to produce, so they are specified, not skipped; see +`PrunedModel/Fuzz.lean`. +-/ + +namespace PrunedModel +namespace PZip + +open PathMapModel + +variable {V : Type} (z : PZip V) + +/-- Replace the trie, keeping the cursor. -/ +def withTrie (t : PrunedMap V) : PZip V := { z with trie := t } + +/-! ## Values at the focus -/ + +/-- `ZipperWriting::get_val_mut` — the same observation as `val`, mutably. +Returns `some` exactly when `val` does; it never creates anything. -/ +def getValMut : Option V := z.val + +/-- `ZipperWriting::set_val`: sets the value at the focus, creating the path if +it did not exist. Returns the replaced value. -/ +def setVal (v : V) : Option V × PZip V := + let (old, t) := z.trie.setVal z.focus v + (old, z.withTrie t) + +/-- Writing through the reference `get_val_mut` returns. + +Specified as: where there is a value, this is `set_val`; where there is not, it +is a no-op — in particular it must **not** create the path, which is what +separates it from `set_val`. -/ +def getValMutWrite (v : V) : Option V × PZip V := + match z.val with + | some old => (some old, (z.setVal v).2) + | none => (none, z) + +/-- `ZipperWriting::get_val_or_set_mut`: the value at the focus, inserting +`default` if there is none. -/ +def getValOrSetMut (d : V) : V × PZip V := + match z.val with + | some v => (v, z) + | none => (d, (z.setVal d).2) + +/-- `ZipperWriting::get_val_or_set_mut_with`: as above, but the value comes from +a closure. + +The documented contract is that the closure supplies the value "if no value +exists", so it must run **exactly when the focus has no value** — running it +otherwise is observable to any caller whose closure has a side effect. The +second component records whether it ran, and the fuzzer compares that too. -/ +def getValOrSetMutWith (d : V) : V × Bool × PZip V := + match z.val with + | some v => (v, false, z) + | none => (d, true, (z.setVal d).2) + +/-- `ZipperWriting::remove_val(true)`. + +The chain above the removed value goes with it, because nothing in this model +can exist without leading to a value. `pathmap`'s own `remove_val(true)` prunes +only as far as the zipper's root, which is why the fuzzer keeps the write zipper +at the map root. -/ +def removeVal : Option V × PZip V := + match z.val with + | none => (none, z) + | some v => (some v, z.withTrie (z.trie.removeVal z.focus).2) + +/-! ## Pruning + +`prune_path` and `prune_ascend` are in the fuzzer's table but have nothing to do +here: a trie built from this subset has no dangling tip to prune (see +`Spec.no_dangling_tip`), so both are no-ops returning `0`. A non-zero count +from the crate is therefore a *finding* — it means some operation in the subset +left a dangling path for `prune_path` to find. -/ + +/-- `ZipperWriting::prune_path`: `0`, and nothing removed. -/ +def prunePath : Nat × PZip V := (0, z) + +/-- `ZipperWriting::prune_ascend`: `prune_path` followed by ascending that far, +so also a no-op. -/ +def pruneAscend : Nat × PZip V := (0, z) + +/-! ## Removing subtries -/ + +/-- `ZipperWriting::remove_branches`: delete everything strictly below the focus. +The value at the focus survives; if there is none, the focus stops existing. +Returns whether anything was removed. -/ +def removeBranches : Bool × PZip V := + (!z.focusNodeIsEmpty, z.withTrie (z.trie.removeBelow z.focus)) + +/-- `ZipperWriting::remove_unmasked_branches`: keep only the child bytes set in +`mask`; delete the rest along with their subtries. -/ +def removeUnmaskedBranches (mask : ByteMask) : PZip V := + let doomed := z.childMask.filter (fun b => !mask.contains b) + z.withTrie <| doomed.foldl (fun t b => t.removeAt (z.focus ++ [b])) z.trie + +/-! ## Grafting -/ + +/-- Replace the subtrie at the focus with `m`, treating `m` as a whole map: its +root value becomes the focus value (or clears it), and its branches become the +focus's branches. This is `ZipperWriting::graft_map`. -/ +def graftMap (m : PrunedMap V) : PZip V := + let t := z.trie.graftBelow z.focus m + z.withTrie <| + match m.valAt [] with + | some v => (t.setVal z.focus v).2 + | none => (t.removeVal z.focus).2 + +/-- `ZipperWriting::graft`: graft the subtrie at `src`'s focus, root value +included. + +Note what this says when the source is empty: the focus loses its value and its +branches, so — having nothing left to lead to — it stops existing, along with +any ancestor chain that existed only for it. `pathmap` 0.4.0 leaves that chain +behind as a dangling path. The model specifies the removal. -/ +def graft (src : PZip V) : PZip V := z.graftMap src.makeMap + +/-- `ZipperWriting::graft_src_at`: graft the subtrie `k` bytes below `src`'s +focus. -/ +def graftSrcAt (src : PZip V) (k : Path) : PZip V := + z.graftMap (src.trie.subtrie (src.focus ++ k)) + +/-- `ZipperWriting::graft_masked_branches`: graft the source's child branches for +each byte set in `mask`. + +Each set bit is a `graft_src_at` of the source's corresponding child, so the +child's *value* travels with it, and a set bit whose branch is absent from the +source leaves that branch absent here — grafting nothing removes. With +`removeUnset`, branches for clear bits are removed first, so `child_mask` +afterwards is a subset of `mask`; without it they are left alone. + +`WriteZipperCore` overrides the trait's default with a native implementation, so +this really compares two implementations of one contract. -/ +def graftMaskedBranches (src : PZip V) (mask : ByteMask) (removeUnset : Bool) : PZip V := + let z0 := if removeUnset then (z.removeBranches).2 else z + z0.withTrie <| mask.foldl (fun t b => + let child := z0.focus ++ [b] + let m := src.trie.subtrie (src.focus ++ [b]) + let t1 := t.graftBelow child m + match m.valAt [] with + | some v => (t1.setVal child v).2 + | none => (t1.removeVal child).2) z0.trie + +/-- `ZipperWriting::take_map`: remove the subtrie at the focus (value included) +and return it as a map. `none` when there was nothing to take. -/ +def takeMap : Option (PrunedMap V) × PZip V := + let rv := z.val + let below := z.focusNode + let z1 := z.withTrie (z.trie.removeAt z.focus) + let taken := + match rv with + | some v => (below.setVal [] v).2 + | none => below + (if below.isEmptyMap && rv.isNone then none else some taken, z1) + +/-! ## Path surgery -/ + +/-- `ZipperWriting::insert_prefix`: put `pre` in front of every path in the +subtrie, the path to the focus value included. The cursor stays where it is. +An empty prefix is the identity. Returns whether the focus exists; a focus that +does not leaves the trie unchanged. -/ +def insertPrefix (pre : Path) : Bool × PZip V := + if !z.pathExists then (false, z) + else if pre.isEmpty then (true, z) + else (true, z.graftMap (z.makeMap.prepend pre)) + +/-- `ZipperWriting::remove_prefix`: move the focused subtrie up by `n` bytes, +replacing the subtrie at the new focus — value included, so the old focus value +replaces the new focus's, or clears it. Returns how many bytes it ascended. -/ +def removePrefix (n : Nat) : Nat × PZip V := + let subtrie := z.makeMap + let (ascended, z1) := z.ascend n + (ascended, z1.graftMap subtrie) + +/-! ## Algebraic operations + +`AlgebraicStatus` is decided structurally: `Identity` exactly when the output +equals the input, `None` when the output is empty, `Element` otherwise. +`Identity(COUNTER_IDENT)` — the output equals the *source* — is reported as +`Element` by `pathmap`, and the model agrees, because the output still differs +from `self`. -/ + +variable (ops : ValOps V) + +/-- The status of replacing `before` with `after`. -/ +def nodeStatus (before after : PrunedMap V) : AlgStatus := + if after.isEmptyMap then .none + else if PrunedMap.beqT ops after before then .identity + else .element + +/-- `ZipperWriting::join_into`: union the subtrie at the source's focus into the +subtrie at this focus, focus values included. -/ +def joinInto (src : PZip V) : AlgStatus × PZip V := + let (valStatus, z1) := + match z.val, src.val with + | some sv, some mv => + let r := ops.pjoin sv mv + (AlgStatus.ofValRes r, + match r.resolve sv mv with + | some v => (z.setVal v).2 + | none => (z.removeVal).2) + | none, some mv => (AlgStatus.element, (z.setVal mv).2) + | some _, none => (AlgStatus.identity, z) + | none, none => (AlgStatus.none, z) + let selfB := z1.focusNode + let srcB := src.focusNode + let r := PrunedMap.join ops selfB srcB + let nodeSt := + if srcB.isEmptyMap then (if selfB.isEmptyMap then AlgStatus.none else AlgStatus.identity) + else if PrunedMap.beqT ops r selfB then AlgStatus.identity else AlgStatus.element + let z2 := + if srcB.isEmptyMap then z1 + else if PrunedMap.beqT ops r selfB then z1 + else z1.withTrie (z1.trie.graftBelow z1.focus r) + (AlgStatus.merge nodeSt valStatus true true, z2) + +/-- `ZipperWriting::join_map_into`: union a consumed map into the focus. + +It short-circuits: when the map has no root node the node status is +returned directly and the value status computed above is discarded — even though +the value has already been written. -/ +def joinMapInto (m : PrunedMap V) : AlgStatus × PZip V := + -- `merge` is called with both "was none" flags set, as the crate does, so the + -- second component is carried only for symmetry with the other operations. + let (valStatus, _valWasNone, z1) := + match z.val, m.valAt [] with + | some sv, some mv => + let r := ops.pjoin sv mv + (AlgStatus.ofValRes r, false, + match r.resolve sv mv with + | some v => (z.setVal v).2 + | none => (z.removeVal).2) + | none, some mv => (AlgStatus.element, true, (z.setVal mv).2) + | some _, none => (AlgStatus.identity, false, z) + | none, none => (AlgStatus.none, true, z) + let srcB := (m.removeVal []).2 + if srcB.isEmptyMap then + -- Note the asymmetry with `join_into`: this branch tests + -- `self.get_focus().is_none()` (does a node exist at all?), not + -- `node_is_empty()`. The two coincide here, since a location that exists + -- has something below it or a value of its own. + -- + -- The node status is *merged* with the value status rather than returned on + -- its own. It used to be returned directly -- an early `return` that + -- discarded a value the operation had already written -- which is + -- issue #139, fixed by PR #142 (`276fca0`). + (AlgStatus.merge + (if z1.pathExists then AlgStatus.identity else AlgStatus.none) valStatus true true, z1) + else + let selfB := z1.focusNode + let r := PrunedMap.join ops selfB srcB + let nodeSt := if PrunedMap.beqT ops r selfB then AlgStatus.identity else AlgStatus.element + let z2 := if nodeSt == .identity then z1 else z1.withTrie (z1.trie.graftBelow z1.focus r) + (AlgStatus.merge nodeSt valStatus true true, z2) + +/-- `ZipperWriting::meet_into`: intersect the focus's subtrie with the source's. + +The value step runs first and can prune the focus out from under the node step. -/ +def meetInto (src : PZip V) : AlgStatus × PZip V := + let (valStatus, valWasNone, z1) := + match z.val, src.val with + | some sv, some ov => + let r := ops.pmeet sv ov + (AlgStatus.ofValRes r, false, + match r.resolve sv ov with + | some v => (z.setVal v).2 + | none => (z.removeVal).2) + | none, some _ => (AlgStatus.none, true, z) + | some _, none => (AlgStatus.none, false, (z.removeVal).2) + | none, none => (AlgStatus.none, true, z) + let selfB := z1.focusNode + let srcB := src.focusNode + if selfB.isEmptyMap then + (AlgStatus.merge .none valStatus true valWasNone, z1) + else if srcB.isEmptyMap then + (AlgStatus.merge .none valStatus false valWasNone, + z1.withTrie (z1.trie.removeBelow z1.focus)) + else + let r := PrunedMap.meet ops selfB srcB + let st := nodeStatus ops selfB r + let z2 := if st == .identity then z1 else z1.withTrie (z1.trie.graftBelow z1.focus r) + (AlgStatus.merge st valStatus false valWasNone, z2) + +/-- `ZipperWriting::subtract_into`: remove the source's subtrie from the focus's. + +Pointwise. `PathMapModel` needs a second rule here — where the source has no +node at all, `self`'s subtree survives untouched, dangling paths included — and +that rule is exactly what the missing `Option` makes unnecessary: with nothing +valueless to preserve, "keep verbatim" and "subtract pointwise" agree. -/ +def subtractInto (src : PZip V) : AlgStatus × PZip V := + let (valStatus, valWasNone, z1) := + match z.val, src.val with + | some sv, some ov => + let r := ops.psub sv ov + (AlgStatus.ofValRes r, false, + match r.resolve sv ov with + | some v => (z.setVal v).2 + | none => (z.removeVal).2) + | none, some _ => (AlgStatus.none, true, z) + | some _, none => (AlgStatus.identity, false, z) + | none, none => (AlgStatus.none, true, z) + let selfB := z1.focusNode + let srcB := src.focusNode + if srcB.isEmptyMap then + (AlgStatus.merge (if selfB.isEmptyMap then .none else .identity) valStatus + selfB.isEmptyMap valWasNone, z1) + else if selfB.isEmptyMap then + (AlgStatus.merge .none valStatus true valWasNone, z1) + else + let r := PrunedMap.sub ops selfB srcB + let st := nodeStatus ops selfB r + let z2 := if st == .identity then z1 else z1.withTrie (z1.trie.graftBelow z1.focus r) + (AlgStatus.merge st valStatus false valWasNone, z2) + +/-- `ZipperWriting::meet_2`: replace the subtrie at the focus with the meet of two +source subtries, focus values included. What is already at the focus is not an +operand, so it reports `Element` or `None`, never `Identity`. -/ +def meet2 (a b : PZip V) : AlgStatus × PZip V := + let r := PrunedMap.meet ops a.makeMap b.makeMap + (if r.isEmptyMap then .none else .element, z.graftMap r) + +/-- `ZipperWriting::restrict`: keep only the paths in this subtrie that are +prefixed by a path to a value in the source's subtrie, as `PathMap::restrict` +does. A source focus value keeps the whole subtrie; without one, the focus +value goes. An empty result reports `None`. -/ +def restrict (src : PZip V) : AlgStatus × PZip V := + if src.val.isSome then + (if z.makeMap.isEmptyMap then .none else .identity, z) + else + let removedVal := z.val + let z1 := z.removeVal.2 + let srcB := src.focusNode + let selfB := z1.focusNode + if srcB.isEmptyMap then (.none, z1.withTrie (z1.trie.removeBelow z1.focus)) + else if selfB.isEmptyMap then (.none, z1) + else + let r := PrunedMap.restrictBelowRoot selfB srcB + let st := nodeStatus ops selfB r + if st == .identity then + (if removedVal.isSome then .element else .identity, z1) + else (st, z1.withTrie (z1.trie.graftBelow z1.focus r)) + +/-- `ZipperWriting::restricting`: the mirror image — `self`'s subtrie is replaced +by the source's, restricted by the paths to values in `self`. + +`false`, leaving `self` untouched, when either side has nothing below its focus. -/ +def restricting (src : PZip V) : Bool × PZip V := + if src.focusNodeIsEmpty then (false, z) + else if z.focusNodeIsEmpty then (false, z) + else (true, z.withTrie (z.trie.graftBelow z.focus + (PrunedMap.restrictBelowRoot src.focusNode z.focusNode))) + +/-! ## Collapsing path segments -/ + +/-- `ZipperWriting::join_k_path_into` (a.k.a. `drop_head`): replace the subtrie +at the focus with the join of the subtries `k` bytes below it. Values at +exactly that depth become the focus value; shallower ones, the old focus value +included, are dropped. `k = 0` is the identity. Returns whether the result is +non-empty. -/ +def joinKPathInto (k : Nat) : Bool × PZip V := + let r := PrunedMap.dropHead ops z.makeMap k + (!r.isEmptyMap, if k == 0 then z else z.graftMap r) + +/-- One step of `meet_k_path_into`: meet in the subtrie at `f ++ q`. -/ +def meetStep (t : PrunedMap V) (f : Path) (acc : Option (PrunedMap V)) (q : Path) : + Option (PrunedMap V) := + match acc with + | none => some (t.subtrie (f ++ q)) + | some a => some (PrunedMap.meet ops a (t.subtrie (f ++ q))) + +/-- `ZipperWriting::meet_k_path_into`: strip the leading `k` bytes from every +path below the focus and meet the results. + +Values at depth exactly `k` become the focus value. The meet replaces the whole +subtrie, focus value included: an empty meet is `remove_subtrie`, which is +grafting the empty map. With `k = 0` the only subtrie is the focus's own, so +it is the identity; a focus with no children meets nothing and is emptied. -/ +def meetKPathInto (k : Nat) : Bool × PZip V := + let kps := (z.trie.subtrie z.focus).kPaths k + let result : Option (PrunedMap V) := kps.foldl (meetStep ops z.trie z.focus) none + match result with + | some m => (!m.isEmptyMap, z.graftMap m) + | none => (false, z.graftMap PrunedMap.empty) + +end PZip +end PrunedModel diff --git a/lean/PrunedModel/Zipper.lean b/lean/PrunedModel/Zipper.lean new file mode 100644 index 00000000..b8da5b53 --- /dev/null +++ b/lean/PrunedModel/Zipper.lean @@ -0,0 +1,331 @@ +import PrunedModel.Map + +/-! +# The zipper, over a trie with no dangling paths + +Same cursor as `PathMapModel.Zip` — a trie, the absolute path the zipper was +created at, and the relative path to the focus — and the same read API. What +changes is what the observations *mean*: + +* `path_exists` is now "some value lies at or below here", because that is the + only way to exist. +* `child_mask` is read off the keys rather than off a separate set of locations. +* `descend_until`, `ascend_until_branch`, `to_next_step` and the `k`-path + primitives walk the prefix closure of the keys, which is the whole trie. + +Everything else is a transcription of `PathMapModel.Zipper`, and deliberately so: +the point of the second model is a different *representation* of the same +contract, not a different reading of it. Where the two models disagree, one of +them is wrong, and the fuzzer says which. + +## The write zipper is rooted at the map root + +`PrunedModel`'s fuzzer only ever builds a write zipper at the map root; see +`Fuzz.header`. A write zipper rooted below it holds a node at its own root, +which survives as a dangling path once everything below it is removed, and +`prune_path` is documented not to rise above the zipper's origin. That is a +location that exists without leading to a value, so it is outside this model by +construction rather than by a bug. Off-root *writing* is still covered — the +root-rooted zipper reaches it with `descend_to`. +-/ + +namespace PrunedModel + +open PathMapModel + +/-- A zipper: a trie, the absolute path of the zipper's root, and the relative +path to the focus. -/ +structure PZip (V : Type) where + trie : PrunedMap V + root : Path + path : Path +deriving Repr + +namespace PZip + +variable {V : Type} (z : PZip V) + +/-- `ZipperAbsolutePath::origin_path`: the absolute path of the focus. -/ +def focus : Path := z.root ++ z.path + +/-- `ZipperAbsolutePath::root_prefix_path`. -/ +def rootPrefixPath : Path := z.root + +/-- All locations of the zipper's subtrie, relative to its root, in depth-first +order. The zipper's entire visible universe. -/ +def subPaths : List Path := (z.trie.subtrie z.root).paths + +/-! ## `trait Zipper` -/ + +/-- `Zipper::path_exists`. -/ +def pathExists : Bool := z.trie.pathExists z.focus + +/-- `Zipper::is_val`. -/ +def isVal : Bool := (z.trie.valAt z.focus).isSome + +/-- `Zipper::child_mask`. -/ +def childMask : ByteMask := z.trie.childMask z.focus + +/-- `Zipper::child_count`. -/ +def childCount : Nat := z.childMask.length + +/-- `ZipperMoving::focus_byte`: the byte last descended to reach the focus. +**Unspecified at the root**; the harness masks it there. -/ +def focusByte : Option UInt8 := z.path.getLast? + +/-! ## `trait ZipperValues` -/ + +/-- `ZipperValues::val`. -/ +def val : Option V := z.trie.valAt z.focus + +/-- `ZipperValues::val_at`: the value at `k`, relative to the focus. -/ +def valAt (k : Path) : Option V := z.trie.valAt (z.focus ++ k) + +/-! ## `trait ZipperSubtries` -/ + +/-- `ZipperInfallibleSubtries::make_map`. Under the default `graft_root_vals` +feature the value at the focus becomes the new map's root value. -/ +def makeMap : PrunedMap V := z.trie.subtrie z.focus + +/-- The node below the focus — what `get_focus` returns. This, not `makeMap`, +is what the algebraic operations and `graft_internal` consume. -/ +def focusNode : PrunedMap V := (z.makeMap.removeVal []).2 + +/-- `get_focus().is_none()`: the focus has no descendants. -/ +def focusNodeIsEmpty : Bool := z.trie.belowIsEmpty z.focus + +/-! ## `trait ZipperMoving` — position -/ + +/-- The same zipper with its focus at the relative path `q`, so that an ancestor +or descendant can be named and then asked about. -/ +def atPath (q : Path) : PZip V := { z with path := q } + +/-- `ZipperMoving::at_root`. -/ +def atRoot : Bool := z.path.isEmpty + +/-- `ZipperMoving::reset`. -/ +def reset : PZip V := { z with path := [] } + +/-- `ZipperMoving::val_count`: values at and below the focus. -/ +def valCount : Nat := z.trie.valCount z.focus + +/-! ## `trait ZipperMoving` — descent -/ + +/-- `ZipperMoving::descend_to`. Never fails; the focus may end up off-trie. -/ +def descendTo (k : Path) : PZip V := { z with path := z.path ++ k } + +/-- `ZipperMoving::descend_to_byte`. -/ +def descendToByte (b : UInt8) : PZip V := z.descendTo [b] + +/-- `ZipperMoving::descend_to_check`: descend, then report existence. -/ +def descendToCheck (k : Path) : Bool × PZip V := + let z' := z.descendTo k + (z'.pathExists, z') + +/-- `ZipperMoving::descend_to_existing`: descend byte by byte, stopping where the +path stops existing. Returns the number of bytes actually descended. -/ +def descendToExisting (k : Path) : Nat × PZip V := + -- Existence is prefix-closed, so the prefixes of `k` that still exist form an + -- initial segment: the answer is the longest prefix of `k` that exists. + let reach := ((List.range (k.length + 1)).filter + (fun j => (z.descendTo (k.take j)).pathExists)).getLast?.getD 0 + (reach, z.descendTo (k.take reach)) + +/-- `ZipperMoving::descend_to_val`: descend byte by byte, stopping at the first +value encountered *below* the starting focus, or where the path stops existing. -/ +def descendToVal (k : Path) : Nat × PZip V := + let reach := ((List.range (k.length + 1)).filter + (fun j => (z.descendTo (k.take j)).pathExists)).getLast?.getD 0 + let stop := ((List.range (reach + 1)).filter + (fun j => 0 < j && (z.descendTo (k.take j)).isVal)).head?.getD reach + (stop, z.descendTo (k.take stop)) + +/-- `ZipperMoving::descend_to_existing_byte`. -/ +def descendToExistingByte (b : UInt8) : Bool × PZip V := + let z' := z.descendToByte b + if z'.pathExists then (true, z') else (false, z) + +/-- `ZipperMoving::descend_indexed_byte`: descend into the `idx`-th child in +ascending byte order, returning the byte moved to. -/ +def descendIndexedByte (idx : Nat) : Option UInt8 × PZip V := + match z.childMask.indexedBit idx with + | some b => (some b, z.descendToByte b) + | none => (none, z) + +/-- `ZipperMoving::descend_first_byte`. -/ +def descendFirstByte : Option UInt8 × PZip V := z.descendIndexedByte 0 + +/-- `ZipperMoving::descend_last_byte`. -/ +def descendLastByte : Option UInt8 × PZip V := + let c := z.childCount + if c == 0 then (none, z) else z.descendIndexedByte (c - 1) + +/-- `ZipperMoving::descend_until`: descend while there is exactly one child, +stopping on a value. A no-op on a branch, a leaf, or a non-existent path. + +The destination is the *nearest* descendant that carries a value or is not +single-childed; `subPaths` is in depth-first order, which along a chain is order +of increasing depth, so `find?` returns it. -/ +def descendUntil : Bool × PZip V := + if z.childCount != 1 then (false, z) + else + match (z.subPaths.filter (fun q => z.path ≼ q && Path.lt z.path q)).find? + (fun q => (z.atPath q).isVal || (z.atPath q).childCount != 1) with + | some q => (true, z.atPath q) + | none => (false, z) + +/-- `ZipperMoving::descend_until_observed`: `descend_until`, reporting each byte +it descends. For the `Vec` observer the reported sequence must be exactly +the path delta — the only way a blind zipper learns where it ended up. -/ +def descendUntilObserved : Bool × Path × PZip V := + let (moved, z2) := z.descendUntil + (moved, z2.path.drop z.path.length, z2) + +/-- `ZipperMoving::descend_until_max_bytes`: `descend_until`, then ascend back to +at most `maxBytes` below the starting depth. -/ +def descendUntilMaxBytes (maxBytes : Nat) : Bool × PZip V := + if maxBytes == 0 then (false, z) + else + let target := z.path.length + maxBytes + let (moved, z') := z.descendUntil + if z'.path.length > target then (moved, { z' with path := z'.path.take target }) + else (moved, z') + +/-! ## `trait ZipperMoving` — ascent -/ + +/-- `ZipperMoving::ascend`: ascend `steps` bytes, clamping at the zipper root. +Returns the number of bytes actually ascended. -/ +def ascend (steps : Nat) : Nat × PZip V := + let n := min steps z.path.length + (n, { z with path := z.path.take (z.path.length - n) }) + +/-- `ZipperMoving::ascend_byte`: `ascend(1) == 1`. -/ +def ascendByte : Bool × PZip V := + let (n, z2) := z.ascend 1 + (n == 1, z2) + +/-- `ZipperMoving::ascend_until`: ascend to the nearest strict ancestor that +carries a value or branches, or to the root. Returns the bytes ascended. + +`properPrefixes` is shortest-first, so the last qualifying element is the +deepest; the root always qualifies, so there is always an answer. -/ +def ascendUntil : Nat × PZip V := + if z.atRoot then (0, z) + else + let stops := (Path.properPrefixes z.path).filter fun a => + a.isEmpty || (z.atPath a).isVal || (z.atPath a).childCount > 1 + let a := (stops.getLast?).getD [] + (z.path.length - a.length, z.atPath a) + +/-- `ZipperMoving::ascend_until_branch`: as above, but values do not stop it. -/ +def ascendUntilBranch : Nat × PZip V := + if z.atRoot then (0, z) + else + let stops := (Path.properPrefixes z.path).filter fun a => + a.isEmpty || (z.atPath a).childCount > 1 + let a := (stops.getLast?).getD [] + (z.path.length - a.length, z.atPath a) + +/-! ## `trait ZipperMoving` — lateral movement -/ + +/-- `ZipperMoving::to_next_sibling_byte`. + +At the zipper root there is no last byte, so the documented answer — and the +`ZipperMoving` default implementation's — is "did not move". The native +`ReadZipper` instead consults the last byte of the *absolute* origin path and +can leave its own root (FINDINGS.md #3); the fuzzer skips the operation at the +root so that known bug does not mask others. -/ +def toNextSiblingByte : Option UInt8 × PZip V := + match z.focusByte with + | none => (none, z) + | some cur => + if z.atRoot then (none, z) + else + let up := (z.ascendByte).2 + match up.childMask.nextBit cur with + | some b => (some b, up.descendToByte b) + | none => (none, z) + +/-- `ZipperMoving::to_prev_sibling_byte`. -/ +def toPrevSiblingByte : Option UInt8 × PZip V := + match z.focusByte with + | none => (none, z) + | some cur => + if z.atRoot then (none, z) + else + let up := (z.ascendByte).2 + match up.childMask.prevBit cur with + | some b => (some b, up.descendToByte b) + | none => (none, z) + +/-- `ZipperMoving::move_to_path`: jump to `p` relative to the zipper root. +Returns the number of bytes shared with the old location. -/ +def moveToPath (p : Path) : Nat × PZip V := + let overlap := ((List.range (min p.length z.path.length)).takeWhile + (fun i => p[i]? == z.path[i]?)).length + (overlap, { z with path := p }) + +/-! ## `trait ZipperMoving` — depth-first stepping -/ + +/-- `ZipperMoving::to_next_step`: the next existing location in depth-first +order. On exhaustion the focus returns to the root and the result is `false`. -/ +def toNextStep : Bool × PZip V := + match z.subPaths.find? (fun q => Path.lt z.path q) with + | some q => (true, { z with path := q }) + | none => (false, z.reset) + +/-! ## `trait ZipperIteration` -/ + +/-- `ZipperIteration::to_next_val`: the next location carrying a value, in +depth-first order. Never reports the value at the starting focus. -/ +def toNextVal : Bool × PZip V := + match z.subPaths.find? + (fun q => Path.lt z.path q && (z.trie.valAt (z.root ++ q)).isSome) with + | some q => (true, { z with path := q }) + | none => (false, z.reset) + +/-- `ZipperReadOnlyIteration::to_next_get_val`. -/ +def toNextGetVal : Option V × PZip V := + let (moved, z') := z.toNextVal + (if moved then z'.val else none, z') + +/-- `ZipperIteration::descend_last_path`: follow the last child to the end of +the depth-first-greatest path below the focus. -/ +def descendLastPath : Bool × PZip V := + let cands := z.subPaths.filter (fun q => z.path ≼ q) + match cands.getLast? with + | some q => if q == z.path then (false, z) else (true, { z with path := q }) + | none => (false, z) + +/-- The shared core of `descend_first_k_path` and `to_next_k_path` +(`k_path_internal`): the depth-first-least existing location exactly `k` bytes +below the common ancestor at depth `base`, strictly after the current focus. On +failure the focus moves to that ancestor. -/ +def kPathFrom (base k : Nat) : Bool × PZip V := + let anc := z.path.take base + match z.subPaths.find? + (fun q => q.length == base + k && anc ≼ q && Path.lt z.path q) with + | some q => (true, { z with path := q }) + | none => (false, { z with path := anc }) + +/-- `ZipperIteration::descend_first_k_path`. -/ +def descendFirstKPath (k : Nat) : Bool × PZip V := z.kPathFrom z.path.length k + +/-- `ZipperIteration::to_next_k_path`: the next existing location at the same +depth, under the common ancestor `k` bytes above the focus. + +When the focus is shallower than `k` the native `ReadZipper` falls back to the +**zipper root** as the common ancestor, so the call behaves like +`descend_first_k_path(k)` from the root and can succeed; the `ZipperIteration` +default returns `false` without moving. The model follows the native one, which +is what the public API reaches. -/ +def toNextKPath (k : Nat) : Bool × PZip V := + if k ≤ z.path.length then z.kPathFrom (z.path.length - k) k else z.kPathFrom 0 k + +/-! ## `trait ZipperForking` -/ + +/-- `ZipperForking::fork_read_zipper`: a new zipper rooted at the current focus. -/ +def forkReadZipper : PZip V := { z with root := z.focus, path := [] } + +end PZip +end PrunedModel diff --git a/lean/PrunedModel/Zippy.lean b/lean/PrunedModel/Zippy.lean new file mode 100644 index 00000000..103feeea --- /dev/null +++ b/lean/PrunedModel/Zippy.lean @@ -0,0 +1,1271 @@ +import PrunedModel.Refine + +/-! +# Zippy's set algebra, as laws about zippers + +[`formal.egg`](https://github.com/Adam-Vandervorst/Zippy/blob/b/formal.egg) is +the reference semantics of Zippy's space algebra: a space is a finite set of +paths, and each operator — `Union`, `Intersection`, `Subtraction`, `Wrap`, +`Unwrap`, `Composition`, `Restriction`, `Raffination`, `Head`, `TailsUnion`, +`TailsIntersection`, `IterC`, `Iter`, `Fix` — is given by egglog rewrite rules, +each annotated with the SMT proof that discharges it. The file says of itself +that "no zipper logic lives here: zippers are an optimization and must be +observationally equivalent to this reference". + +This file is that equivalence, for `pathmap`'s zippers, and then the rules. + +## A space is a `PrunedMap Unit` + +`Option Unit` is one bit, so a `PrunedMap Unit` is exactly a finite set of paths +(`Lattice.lean` §5). `Path` is `List UInt8`, so egg's `Item i64` becomes a byte; +the tour's letters `a..z = 10..35` all fit. `Eps` is `[]` and `Concat` is `++`. + +## Every operator is a zipper program + +Each operator is defined by what the model's write zipper does, not by a set +comprehension: `Union` is `join_map_into` at the root of a write zipper over the +first operand, `Unwrap` is `descend_to` then `make_map`, `Head` reads +`child_mask`, and so on (§1). `Refine.lean` proves what each zipper operation +writes at its focus, and §2 turns that into one membership lemma per operator. +Every law in §3–§9 is then a statement about zipper programs, proved from those +membership lemmas alone. + +On this branch (`focus_value_consistency`, issue #104) a subtrie includes the +value at its root, and the five raw zipper operations that used to differ from +their egg operator at the focus value now *are* it — §10 proves each: + +* `join_into` is `Union`; +* `restrict` is `Restriction` (so §1 defines `Restriction` as `restrict`); +* `insert_prefix p` is `Wrap p`; +* `join_k_path_into 1` is `TailsUnion`; +* `meet_k_path_into 1` is `TailsIntersection` — since `482c248`, an empty meet + clears the focus value (`remove_subtrie`) rather than keeping it + (`remove_branches`). + +The two tails operators are still defined by folding `join_map_into` and +`meet_into` over `child_mask`, as egg's rules compute them. + +## What does not carry over + +Nothing in `formal.egg` is false here. Two of its rule groups are algorithms +rather than equations — the `drop-prefix` relation and the +`tails-intersection-acc` fold — and they appear as the equations they compute. +`Fix` is egg's *axiomatisation* of a least post-fixpoint; §9 states it as a +predicate, proves the three rules are its definition, that it is unique, and +that the inflationary iteration every Zippy executor runs reaches it when `F` is +monotone. The `EB` membership-flag algebra is `Bool`'s own and needs no +statement. + +The tour's `(check …)` lines are `#guard`s at the end, `(fail (check …))` as +`#guard !…`. +-/ + +namespace PrunedModel +namespace Zippy + +open PathMapModel PrunedMap + +/-- A space: a finite set of paths. -/ +abbrev Space := PrunedMap Unit + +instance : Membership Path Space := ⟨fun s p => (s.valAt p).isSome = true⟩ + +theorem mem_def {p : Path} {s : Space} : p ∈ s ↔ (s.valAt p).isSome = true := Iff.rfl + +instance (p : Path) (s : Space) : Decidable (p ∈ s) := + inferInstanceAs (Decidable ((s.valAt p).isSome = true)) + +instance : DecidableEq Space := fun a b => + if h : a.entries = b.entries then isTrue (PrunedMap.ext fun k => by rw [h]) + else isFalse fun e => h (by rw [e]) + +/-- **Extensionality.** Two spaces with the same members are equal — which is +what lets every law below be an equation. -/ +theorem ext {a b : Space} (h : ∀ p, p ∈ a ↔ p ∈ b) : a = b := by + apply PrunedMap.ext; intro k + show a.valAt k = b.valAt k + rw [unit_valAt_determined a k, unit_valAt_determined b k] + have := h k + rw [mem_def, mem_def] at this + rw [Bool.eq_iff_iff.mpr this] + +/-- `valAt` of a space is determined by membership. -/ +theorem valAt_eq (s : Space) (p : Path) : s.valAt p = if p ∈ s then some () else none := by + rw [unit_valAt_determined s p]; rfl + +theorem not_mem_iff (s : Space) (p : Path) : p ∉ s ↔ s.valAt p = none := by + rw [mem_def]; cases s.valAt p <;> simp + +/-! ## 1. The operators, as zipper programs -/ + +/-- A write zipper at the root of `s`. -/ +def wz (s : Space) : PZip Unit := ⟨s, [], []⟩ + +/-- `Empty`. -/ +def empty : Space := PrunedMap.empty + +/-- `Singleton p`: `descend_to p`, then `set_val`. -/ +def singleton (p : Path) : Space := (((wz empty).descendTo p).setVal ()).2.trie + +/-- `Union`: `join_map_into` — which joins the root value too — at the root. -/ +def union (a b : Space) : Space := ((wz a).joinMapInto unitOps b).2.trie + +/-- `Intersection`: `meet_into`. -/ +def inter (a b : Space) : Space := ((wz a).meetInto unitOps (wz b)).2.trie + +/-- `Subtraction`: `subtract_into`. -/ +def subtr (a b : Space) : Space := ((wz a).subtractInto unitOps (wz b)).2.trie + +/-- `Wrap p s`: `descend_to p` in an empty map, then `graft_map s`. -/ +def wrap (p : Path) (s : Space) : Space := (((wz empty).descendTo p).graftMap s).trie + +/-- `Unwrap s p`: `descend_to p`, then `make_map`. -/ +def unwrap (s : Space) (p : Path) : Space := ((wz s).descendTo p).makeMap + +/-- `Restriction x y`: the paths of `x` with a prefix in `y` — `restrict`, which +on this branch consults the source's focus value and clears the destination's +when it has none, as `PathMap::restrict` does. -/ +def restriction (x y : Space) : Space := ((wz x).restrict unitOps (wz y)).2.trie + +/-- `Raffination x y`, which egg *defines* as `x \ (x <| y)`. -/ +def raffination (x y : Space) : Space := subtr x (restriction x y) + +/-- `Composition s t`: for each path `u` of `s`, `descend_to u` and +`join_map_into t`. -/ +def composition (s t : Space) : Space := + s.keys.foldl (fun acc u => (((wz acc).descendTo u).joinMapInto unitOps t).2.trie) empty + +/-- `Head s`: one single-byte path per bit of `child_mask`. -/ +def head (s : Space) : Space := (wz s).childMask.foldl (fun acc b => union acc (singleton [b])) empty + +/-- `TailsUnion s`: the union, over `child_mask`, of `descend_to_byte b` then +`make_map`. -/ +def tailsUnion (s : Space) : Space := + (wz s).childMask.foldl (fun acc b => union acc ((wz s).descendToByte b).makeMap) empty + +/-- `TailsIntersection s`: the intersection of the same children — egg's +`tails-intersection-acc` fold, started at the first head. No heads, no +tails. -/ +def tailsInter (s : Space) : Space := + match (wz s).childMask with + | [] => empty + | b :: bs => bs.foldl (fun acc c => inter acc ((wz s).descendToByte c).makeMap) + ((wz s).descendToByte b).makeMap + +/-- One arm of an iteration: the body at head `h`, over `src`'s tails under `h`. -/ +def iterArm (src : Space) (body : UInt8 → Space → Space) : Path → Space + | [h] => body h (unwrap src [h]) + | _ => empty + +/-- `IterH H src body`: the union of `body h (src's tails under h)` over the +single-byte paths `[h]` of `H`. Paths of any other length contribute nothing; +egg has no rule for them, and only `iter` builds an `IterH`. -/ +def iterH (H src : Space) (body : UInt8 → Space → Space) : Space := + H.keys.foldl (fun acc k => union acc (iterArm src body k)) empty + +/-- `Iter src body`: head-dependent iteration, which egg rewrites to +`IterH (Head src) src body` (its rule L1) — so that is its definition here. -/ +def iter (src : Space) (body : UInt8 → Space → Space) : Space := iterH (head src) src body + +/-- `IterC src b`: iteration with a loop-invariant body. -/ +def iterC (src b : Space) : Space := iter src fun _ _ => b + +/-! ## 2. What each zipper program computes -/ + +@[simp] theorem wz_trie (s : Space) : (wz s).trie = s := rfl +@[simp] theorem wz_focus (s : Space) : (wz s).focus = [] := rfl +@[simp] theorem wz_descendTo_focus (s : Space) (p : Path) : ((wz s).descendTo p).focus = p := rfl +@[simp] theorem wz_descendTo_trie (s : Space) (p : Path) : ((wz s).descendTo p).trie = s := rfl + +theorem subtrie_nil (t : Space) : t.subtrie [] = t := + PrunedMap.ext fun k => by + show (t.subtrie []).valAt k = t.valAt k + rw [valAt_subtrie]; rfl + +@[simp] theorem wz_makeMap (s : Space) : (wz s).makeMap = s := subtrie_nil s + +theorem not_mem_empty (p : Path) : p ∉ empty := by simp [mem_def, empty] + +theorem mem_singleton {p q : Path} : p ∈ singleton q ↔ p = q := by + rw [singleton, PZip.setVal_eq, PZip.withTrie_trie, mem_def, valAt_replaceAt] + simp only [wz_descendTo_focus, wz_descendTo_trie] + cases hs : Path.stripPrefix q p with + | none => + simp only [empty, valAt_empty, Option.isSome_none, Bool.false_eq_true, false_iff] + intro h; subst h; rw [PZip.stripPrefix_self] at hs; cases hs + | some r => + have := (Path.stripPrefix_eq_some q p r).mp hs; subst this + dsimp only + rw [valAt_setVal] + by_cases hr : r = [] <;> simp [hr, PZip.valAt_makeMap, empty] + +theorem union_eq_join (a b : Space) : union a b = join unitOps a b := by + rw [union, PZip.joinMapInto_eq _ unitOps_lawful, PZip.withTrie_trie, wz_focus, replaceAt_nil, + wz_makeMap] + +theorem inter_eq_meet (a b : Space) : inter a b = meet unitOps a b := by + rw [inter, PZip.meetInto_eq _ unitOps_lawful, PZip.withTrie_trie, wz_focus, replaceAt_nil, + wz_makeMap, wz_makeMap] + +theorem subtr_eq_sub (a b : Space) : subtr a b = sub unitOps a b := by + rw [subtr, PZip.subtractInto_eq _ unitOps_lawful, PZip.withTrie_trie, wz_focus, replaceAt_nil, + wz_makeMap, wz_makeMap] + +theorem mem_union {p : Path} {a b : Space} : p ∈ union a b ↔ p ∈ a ∨ p ∈ b := by + rw [union_eq_join, mem_def, unit_join_isSome, Bool.or_eq_true]; rfl + +theorem mem_inter {p : Path} {a b : Space} : p ∈ inter a b ↔ p ∈ a ∧ p ∈ b := by + rw [inter_eq_meet, mem_def, unit_meet_isSome, Bool.and_eq_true]; rfl + +theorem mem_subtr {p : Path} {a b : Space} : p ∈ subtr a b ↔ p ∈ a ∧ p ∉ b := by + rw [subtr_eq_sub, mem_def, valAt_sub, mem_def, not_mem_iff] + cases a.valAt p <;> cases hb : b.valAt p <;> simp [subVal, unitOps, ValRes.resolve] + +theorem wrap_eq (p : Path) (s : Space) : wrap p s = empty.replaceAt p s := by + rw [wrap, PZip.graftMap_eq]; rfl + +theorem mem_wrap {p q : Path} {s : Space} : p ∈ wrap q s ↔ ∃ r, p = q ++ r ∧ r ∈ s := by + rw [wrap_eq, mem_def, valAt_replaceAt] + cases hs : Path.stripPrefix q p with + | none => + simp only [empty, valAt_empty, Option.isSome_none, Bool.false_eq_true, false_iff, not_exists, + not_and] + intro r hr; exact absurd hr ((Path.stripPrefix_eq_none q p).mp hs r) + | some r => + have := (Path.stripPrefix_eq_some q p r).mp hs; subst this + constructor + · intro h; exact ⟨r, rfl, h⟩ + · rintro ⟨r', hr', h⟩ + rw [List.append_cancel_left hr']; exact h + +theorem mem_unwrap {p q : Path} {s : Space} : p ∈ unwrap s q ↔ q ++ p ∈ s := by + rw [unwrap, mem_def, PZip.valAt_makeMap]; rfl + +theorem mem_keys {k : Path} {s : Space} : k ∈ s.keys ↔ k ∈ s := by + constructor + · intro h; exact lookup_isSome_of_mem_keys h + · intro h; exact mem_keys_of_lookup_isSome h + +theorem mem_ofList (b : UInt8) (bs : List UInt8) : b ∈ ByteMask.ofList bs ↔ b ∈ bs := by + rw [ByteMask.ofList, List.mem_filterMap] + constructor + · rintro ⟨i, _, hi⟩ + simp only at hi + split at hi + · next hc => cases hi; exact List.contains_iff_mem.mp hc + · cases hi + · intro hb + refine ⟨b.toNat, List.mem_range.mpr (UInt8.toNat_lt b), ?_⟩ + simp only + rw [if_pos (by rw [UInt8.ofNat_toNat]; exact List.contains_iff_mem.mpr hb), UInt8.ofNat_toNat] + +/-- `child_mask` at the root: the first bytes of the paths. -/ +theorem mem_childMask {b : UInt8} {s : Space} : b ∈ (wz s).childMask ↔ ∃ r, b :: r ∈ s := by + show b ∈ s.childMask [] ↔ _ + rw [childMask, mem_ofList, List.mem_filterMap] + constructor + · rintro ⟨k, hk, hb⟩ + have hk' : k ∈ s := mem_keys.mp hk + cases k with + | nil => simp [Path.stripPrefix] at hb + | cons c r => + simp only [Path.stripPrefix, Option.some.injEq] at hb + subst hb; exact ⟨r, hk'⟩ + · rintro ⟨r, hr⟩ + exact ⟨b :: r, mem_keys.mpr hr, rfl⟩ + +/-- Folding a union over a list: a member of the result is a member of the +start or of some step. -/ +theorem mem_foldl_union {α : Type} (f : α → Space) (p : Path) : + ∀ (l : List α) (init : Space), + p ∈ l.foldl (fun acc x => union acc (f x)) init ↔ p ∈ init ∨ ∃ x ∈ l, p ∈ f x + | [], init => by simp + | x :: xs, init => by + rw [List.foldl_cons, mem_foldl_union f p xs, mem_union] + constructor + · rintro ((h | h) | ⟨y, hy, h⟩) + · exact Or.inl h + · exact Or.inr ⟨x, List.mem_cons_self, h⟩ + · exact Or.inr ⟨y, List.mem_cons_of_mem _ hy, h⟩ + · rintro (h | ⟨y, hy, h⟩) + · exact Or.inl (Or.inl h) + · rcases List.mem_cons.mp hy with rfl | hy + · exact Or.inl (Or.inr h) + · exact Or.inr ⟨y, hy, h⟩ + +/-- Folding an intersection over a list. -/ +theorem mem_foldl_inter {α : Type} (f : α → Space) (p : Path) : + ∀ (l : List α) (init : Space), + p ∈ l.foldl (fun acc x => inter acc (f x)) init ↔ p ∈ init ∧ ∀ x ∈ l, p ∈ f x + | [], init => by simp + | x :: xs, init => by + rw [List.foldl_cons, mem_foldl_inter f p xs, mem_inter] + constructor + · rintro ⟨⟨h0, hx⟩, h⟩ + exact ⟨h0, fun y hy => (List.mem_cons.mp hy).elim (fun e => e ▸ hx) (h y)⟩ + · rintro ⟨h0, h⟩ + exact ⟨⟨h0, h x List.mem_cons_self⟩, fun y hy => h y (List.mem_cons_of_mem _ hy)⟩ + +theorem mem_restriction {p : Path} {x y : Space} : + p ∈ restriction x y ↔ p ∈ x ∧ ∃ r s, p = r ++ s ∧ r ∈ y := by + rw [restriction, PZip.restrict_eq _ unitOps_lawful, PZip.withTrie_trie, wz_focus, replaceAt_nil, + wz_makeMap, wz_makeMap] + by_cases hy : (wz y).val.isSome = true + · rw [if_pos hy] + have hy' : [] ∈ y := hy + exact ⟨fun h => ⟨h, [], p, rfl, hy'⟩, fun h => h.1⟩ + · rw [if_neg hy, mem_def, valAt_restrictBelowRoot] + have hy' : [] ∉ y := hy + by_cases hv : validatedBy y p = true + · rw [if_pos hv] + obtain ⟨r, s, _, hrs, hr⟩ := (validatedBy_iff _ _).mp hv + exact ⟨fun h => ⟨h, r, s, hrs, hr⟩, fun h => h.1⟩ + · rw [if_neg hv] + simp only [Option.isSome_none, Bool.false_eq_true, false_iff, not_and] + rintro _ ⟨r, s, hrs, hr⟩ + apply hv + refine (validatedBy_iff _ _).mpr ⟨r, s, ?_, hrs, hr⟩ + rintro rfl; exact hy' hr + +theorem mem_composition_step {p u : Path} {acc t : Space} : + p ∈ (((wz acc).descendTo u).joinMapInto unitOps t).2.trie ↔ p ∈ acc ∨ ∃ v, p = u ++ v ∧ v ∈ t := by + rw [PZip.joinMapInto_eq _ unitOps_lawful, PZip.withTrie_trie, wz_descendTo_trie, + wz_descendTo_focus, mem_def, valAt_replaceAt] + cases hs : Path.stripPrefix u p with + | none => + have hn := (Path.stripPrefix_eq_none u p).mp hs + exact ⟨Or.inl, fun h => h.elim id (fun ⟨v, hv, _⟩ => absurd hv (hn v))⟩ + | some r => + have := (Path.stripPrefix_eq_some u p r).mp hs; subst this + dsimp only + rw [unit_join_isSome, PZip.valAt_makeMap, wz_descendTo_trie, wz_descendTo_focus, + Bool.or_eq_true] + constructor + · rintro (h | h) + · exact Or.inl h + · exact Or.inr ⟨r, rfl, h⟩ + · rintro (h | ⟨v, hv, h⟩) + · exact Or.inl h + · rw [List.append_cancel_left hv]; exact Or.inr h + +theorem mem_composition {p : Path} {s t : Space} : + p ∈ composition s t ↔ ∃ u v, p = u ++ v ∧ u ∈ s ∧ v ∈ t := by + have key : ∀ (l : List Path) (init : Space), + p ∈ l.foldl (fun acc u => (((wz acc).descendTo u).joinMapInto unitOps t).2.trie) init ↔ + p ∈ init ∨ ∃ u ∈ l, ∃ v, p = u ++ v ∧ v ∈ t := by + intro l + induction l with + | nil => intro init; simp + | cons u us ih => + intro init + rw [List.foldl_cons, ih, mem_composition_step] + constructor + · rintro ((h | h) | ⟨w, hw, h⟩) + · exact Or.inl h + · exact Or.inr ⟨u, List.mem_cons_self, h⟩ + · exact Or.inr ⟨w, List.mem_cons_of_mem _ hw, h⟩ + · rintro (h | ⟨w, hw, h⟩) + · exact Or.inl (Or.inl h) + · rcases List.mem_cons.mp hw with rfl | hw + · exact Or.inl (Or.inr h) + · exact Or.inr ⟨w, hw, h⟩ + rw [composition, key] + simp only [not_mem_empty, false_or, mem_keys] + constructor + · rintro ⟨u, hu, v, rfl, hv⟩; exact ⟨u, v, rfl, hu, hv⟩ + · rintro ⟨u, v, rfl, hu, hv⟩; exact ⟨u, hu, v, rfl, hv⟩ + +theorem mem_head {p : Path} {s : Space} : p ∈ head s ↔ ∃ b r, p = [b] ∧ b :: r ∈ s := by + rw [head, mem_foldl_union (fun b => singleton [b])] + simp only [not_mem_empty, false_or, mem_singleton, mem_childMask] + constructor + · rintro ⟨b, ⟨r, hr⟩, rfl⟩; exact ⟨b, r, rfl, hr⟩ + · rintro ⟨b, r, rfl, hr⟩; exact ⟨b, ⟨r, hr⟩, rfl⟩ + +theorem mem_child {p : Path} {s : Space} {b : UInt8} : + p ∈ ((wz s).descendToByte b).makeMap ↔ b :: p ∈ s := by + rw [mem_def, PZip.valAt_makeMap]; rfl + +theorem mem_tailsUnion {p : Path} {s : Space} : p ∈ tailsUnion s ↔ ∃ b, b :: p ∈ s := by + rw [tailsUnion, mem_foldl_union (fun b => ((wz s).descendToByte b).makeMap)] + simp only [not_mem_empty, false_or, mem_child, mem_childMask] + constructor + · rintro ⟨b, _, h⟩; exact ⟨b, h⟩ + · rintro ⟨b, h⟩; exact ⟨b, ⟨p, h⟩, h⟩ + +theorem mem_tailsInter {p : Path} {s : Space} : + p ∈ tailsInter s ↔ (∃ b r, b :: r ∈ s) ∧ ∀ b, (∃ r, b :: r ∈ s) → b :: p ∈ s := by + unfold tailsInter + split + · next hm => + simp only [not_mem_empty, false_iff, not_and] + rintro ⟨b, r, hr⟩ + have : b ∈ (wz s).childMask := mem_childMask.mpr ⟨r, hr⟩ + rw [hm] at this; cases this + · next b bs hm => + rw [mem_foldl_inter (fun c => ((wz s).descendToByte c).makeMap), mem_child] + simp only [mem_child] + have hmask : ∀ c, c ∈ b :: bs ↔ ∃ r, c :: r ∈ s := fun c => by rw [← hm, mem_childMask] + constructor + · rintro ⟨h0, h⟩ + refine ⟨⟨b, (hmask b).mp List.mem_cons_self⟩, fun c hc => ?_⟩ + rcases List.mem_cons.mp ((hmask c).mpr hc) with rfl | hc' + · exact h0 + · exact h c hc' + · rintro ⟨_, h⟩ + exact ⟨h b ((hmask b).mp List.mem_cons_self), + fun c hc => h c ((hmask c).mp (List.mem_cons_of_mem _ hc))⟩ + +theorem mem_iterH {p : Path} {H src : Space} {body : UInt8 → Space → Space} : + p ∈ iterH H src body ↔ ∃ h, [h] ∈ H ∧ p ∈ body h (unwrap src [h]) := by + rw [iterH, mem_foldl_union (iterArm src body)] + simp only [not_mem_empty, false_or, mem_keys] + constructor + · rintro ⟨k, hk, h⟩ + match k, hk, h with + | [c], hk, h => exact ⟨c, hk, h⟩ + | [], _, h => exact absurd h (not_mem_empty p) + | _ :: _ :: _, _, h => exact absurd h (not_mem_empty p) + · rintro ⟨c, hc, h⟩; exact ⟨[c], hc, h⟩ + +theorem mem_iter {p : Path} {src : Space} {body : UInt8 → Space → Space} : + p ∈ iter src body ↔ ∃ h, (∃ r, h :: r ∈ src) ∧ p ∈ body h (unwrap src [h]) := by + rw [iter, mem_iterH] + simp only [mem_head, List.cons.injEq, and_true] + constructor + · rintro ⟨h, ⟨b, r, rfl, hr⟩, hp⟩; exact ⟨h, ⟨r, hr⟩, hp⟩ + · rintro ⟨h, ⟨r, hr⟩, hp⟩; exact ⟨h, ⟨h, r, rfl, hr⟩, hp⟩ + +theorem mem_iterC {p : Path} {src b : Space} : p ∈ iterC src b ↔ (∃ h r, h :: r ∈ src) ∧ p ∈ b := by + rw [iterC, mem_iter] + constructor + · rintro ⟨h, ⟨r, hr⟩, hp⟩; exact ⟨⟨h, r, hr⟩, hp⟩ + · rintro ⟨⟨h, r, hr⟩, hp⟩; exact ⟨h, ⟨r, hr⟩, hp⟩ + +theorem mem_raffination {p : Path} {x y : Space} : + p ∈ raffination x y ↔ p ∈ x ∧ ¬ ∃ r s, p = r ++ s ∧ r ∈ y := by + rw [raffination, mem_subtr, mem_restriction] + constructor + · rintro ⟨hx, hn⟩; exact ⟨hx, fun h => hn ⟨hx, h⟩⟩ + · rintro ⟨hx, hn⟩; exact ⟨hx, fun h => hn h.2⟩ + +/-! ## 3. Membership (`formal.egg` lines 76–88) + +egg's `ElemP p s` judgment, with `EOr`/`EAnd`/`EAndNot` as `∨`/`∧`/`∧ ¬`. The +singleton-disequality case (line 85) is negation-as-failure there, and sound +only at saturation; here it is an ordinary lemma. -/ + +/-- line 83 -/ +theorem elemP_empty (p : Path) : p ∉ empty := not_mem_empty p +/-- line 84 -/ +theorem elemP_singleton (p : Path) : p ∈ singleton p := mem_singleton.mpr rfl +/-- line 85 -/ +theorem elemP_singleton_ne {p q : Path} (h : p ≠ q) : p ∉ singleton q := fun hm => h (mem_singleton.mp hm) +/-- line 86 -/ +theorem elemP_union {p : Path} {a b : Space} : p ∈ union a b ↔ p ∈ a ∨ p ∈ b := mem_union +/-- line 87 -/ +theorem elemP_inter {p : Path} {a b : Space} : p ∈ inter a b ↔ p ∈ a ∧ p ∈ b := mem_inter +/-- line 88 -/ +theorem elemP_subtr {p : Path} {a b : Space} : p ∈ subtr a b ↔ p ∈ a ∧ p ∉ b := mem_subtr + +/-! ## 4. Union, intersection, subtraction (lines 90–117) + +`join_map_into`, `meet_into` and `subtract_into` at the root of a write zipper. +`Lattice.lean` already has most of these for `join`/`meet`; here they are about +the zipper programs, and subtraction is new. -/ + +section Boolean +variable (x y z : Space) + +/-- line 90 -/ +theorem union_idem : union x x = x := ext fun p => by rw [mem_union, or_self] +/-- line 91 -/ +theorem inter_idem : inter x x = x := ext fun p => by rw [mem_inter, and_self] +/-- line 93 -/ +theorem subtr_self : subtr x x = empty := ext fun p => by + rw [mem_subtr]; exact ⟨fun h => absurd h.1 h.2, fun h => absurd h (not_mem_empty p)⟩ +/-- line 96 -/ +theorem union_comm : union x y = union y x := ext fun p => by rw [mem_union, mem_union, or_comm] +/-- line 97 -/ +theorem inter_comm : inter x y = inter y x := ext fun p => by rw [mem_inter, mem_inter, and_comm] +/-- line 99 -/ +theorem union_empty : union x empty = x := ext fun p => by + rw [mem_union]; exact ⟨fun h => h.resolve_right (not_mem_empty p), Or.inl⟩ +/-- line 100 -/ +theorem empty_union : union empty x = x := by rw [union_comm, union_empty] +/-- line 101 -/ +theorem inter_empty : inter x empty = empty := ext fun p => by + rw [mem_inter]; exact ⟨fun h => h.2, fun h => absurd h (not_mem_empty p)⟩ +/-- line 102 -/ +theorem empty_inter : inter empty x = empty := by rw [inter_comm, inter_empty] +/-- line 103 -/ +theorem union_inter_distrib : inter (union x y) z = union (inter x z) (inter y z) := ext fun p => by + simp only [mem_union, mem_inter] + by_cases hx : p ∈ x <;> by_cases hy : p ∈ y <;> by_cases hz : p ∈ z <;> simp [hx, hy, hz] +/-- line 104 -/ +theorem inter_union_distrib : inter x (union y z) = union (inter x y) (inter x z) := ext fun p => by + simp only [mem_union, mem_inter] + by_cases hx : p ∈ x <;> by_cases hy : p ∈ y <;> by_cases hz : p ∈ z <;> simp [hx, hy, hz] +/-- line 105 -/ +theorem empty_subtr : subtr empty x = empty := ext fun p => by + rw [mem_subtr]; exact ⟨fun h => h.1, fun h => absurd h (not_mem_empty p)⟩ +/-- line 106 -/ +theorem subtr_empty : subtr x empty = x := ext fun p => by + rw [mem_subtr]; exact ⟨fun h => h.1, fun h => ⟨h, not_mem_empty p⟩⟩ +/-- line 107 -/ +theorem union_subtr_distrib : subtr (union x y) z = union (subtr x z) (subtr y z) := ext fun p => by + simp only [mem_union, mem_subtr] + by_cases hx : p ∈ x <;> by_cases hy : p ∈ y <;> by_cases hz : p ∈ z <;> simp [hx, hy, hz] +/-- line 108 -/ +theorem subtr_union : subtr x (union y z) = subtr (subtr x y) z := ext fun p => by + simp only [mem_union, mem_subtr] + by_cases hx : p ∈ x <;> by_cases hy : p ∈ y <;> by_cases hz : p ∈ z <;> simp [hx, hy, hz] +/-- line 116 -/ +theorem union_assoc : union (union x y) z = union x (union y z) := ext fun p => by + simp only [mem_union, or_assoc] +/-- line 117 -/ +theorem inter_assoc : inter (inter x y) z = inter x (inter y z) := ext fun p => by + simp only [mem_inter, and_assoc] + +end Boolean + +/-- line 109 -/ +theorem singleton_subtr_singleton {p q : Path} (h : p ≠ q) : + subtr (singleton p) (singleton q) = singleton p := ext fun r => by + simp only [mem_subtr, mem_singleton] + exact ⟨fun h' => h'.1, fun h' => ⟨h', fun e => h (h'.symm.trans e)⟩⟩ +/-- line 110 -/ +theorem singleton_inter_singleton {p q : Path} (h : p ≠ q) : + inter (singleton p) (singleton q) = empty := ext fun r => by + simp only [mem_inter, mem_singleton] + exact ⟨fun ⟨h1, h2⟩ => absurd (h1.symm.trans h2) h, fun h' => absurd h' (not_mem_empty r)⟩ + +/-! Paths (lines 112–115) are `List UInt8` under `++`; these are core lemmas. -/ + +/-- line 112 -/ +theorem concat_eps (x : Path) : x ++ [] = x := List.append_nil x +/-- line 113 -/ +theorem eps_concat (x : Path) : [] ++ x = x := List.nil_append x +/-- line 115 -/ +theorem concat_assoc (x y z : Path) : (x ++ y) ++ z = x ++ (y ++ z) := List.append_assoc x y z + +/-! ## 5. Wrap and unwrap (lines 119–153, 199–200) + +`Wrap` is `graft_map` at a descended focus of an empty map; `Unwrap` is +`descend_to` then `make_map`. egg needs the `drop-prefix` relation and ten rules +to compute `Unwrap` of a singleton; here it is one equation, +`unwrap_singleton`, and those rules are its cases. -/ + +/-- line 119 -/ +theorem wrap_empty (x : Path) : wrap x empty = empty := ext fun p => by + rw [mem_wrap] + exact ⟨fun ⟨_, _, h⟩ => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty p)⟩ +/-- line 120 -/ +theorem wrap_eps (s : Space) : wrap [] s = s := ext fun p => by + rw [mem_wrap]; exact ⟨fun ⟨r, hr, h⟩ => by simpa [hr] using h, fun h => ⟨p, rfl, h⟩⟩ +/-- line 121 -/ +theorem wrap_singleton (x p : Path) : wrap x (singleton p) = singleton (x ++ p) := ext fun q => by + rw [mem_wrap, mem_singleton] + simp only [mem_singleton, exists_eq_right] +/-- line 122 -/ +theorem wrap_union (x : Path) (s t : Space) : wrap x (union s t) = union (wrap x s) (wrap x t) := + ext fun p => by + simp only [mem_wrap, mem_union] + constructor + · rintro ⟨r, rfl, h | h⟩ + · exact Or.inl ⟨r, rfl, h⟩ + · exact Or.inr ⟨r, rfl, h⟩ + · rintro (⟨r, rfl, h⟩ | ⟨r, rfl, h⟩) + · exact ⟨r, rfl, Or.inl h⟩ + · exact ⟨r, rfl, Or.inr h⟩ + +/-- line 124 -/ +theorem unwrap_empty (p : Path) : unwrap empty p = empty := ext fun q => by + rw [mem_unwrap]; exact ⟨fun h => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty _)⟩ +/-- line 125 -/ +theorem unwrap_eps (s : Space) : unwrap s [] = s := ext fun q => by rw [mem_unwrap]; rfl +/-- line 126 -/ +theorem unwrap_wrap (p : Path) (s : Space) : unwrap (wrap p s) p = s := ext fun q => by + rw [mem_unwrap, mem_wrap] + exact ⟨fun ⟨r, hr, h⟩ => by rwa [List.append_cancel_left hr], fun h => ⟨q, rfl, h⟩⟩ +/-- line 127 -/ +theorem unwrap_wrap_append (p q : Path) (s : Space) : unwrap (wrap (p ++ q) s) p = wrap q s := + ext fun r => by + rw [mem_unwrap, mem_wrap, mem_wrap] + simp only [List.append_assoc, List.append_cancel_left_eq] +/-- line 128 -/ +theorem unwrap_wrap_of_append (p q : Path) (s : Space) : unwrap (wrap p s) (p ++ q) = unwrap s q := + ext fun r => by + rw [mem_unwrap, mem_wrap, mem_unwrap] + simp only [List.append_assoc, List.append_cancel_left_eq, exists_eq_left'] +/-- line 129 -/ +theorem unwrap_union (s t : Space) (x : Path) : unwrap (union s t) x = union (unwrap s x) (unwrap t x) := + ext fun q => by simp only [mem_unwrap, mem_union] +/-- line 199 -/ +theorem unwrap_unwrap (s : Space) (p q : Path) : unwrap (unwrap s p) q = unwrap s (p ++ q) := + ext fun r => by simp only [mem_unwrap, List.append_assoc] +/-- line 200 -/ +theorem unwrap_wrap_ne {a b : UInt8} (h : a ≠ b) (s : Space) : unwrap (wrap [a] s) [b] = empty := + ext fun q => by + rw [mem_unwrap, mem_wrap] + simp only [List.cons_append, List.nil_append, List.cons.injEq] + exact ⟨fun ⟨_, ⟨e, _⟩, _⟩ => absurd e.symm h, fun h' => absurd h' (not_mem_empty q)⟩ + +/-- **Unwrapping a singleton** (lines 131–153, the `drop-prefix` relation). `p` +unwraps `{w}` to `{r}` when `w = p ++ r`, and to nothing otherwise. -/ +theorem unwrap_singleton (w p : Path) : + unwrap (singleton w) p = match Path.stripPrefix p w with + | some r => singleton r + | none => empty := by + apply ext; intro q + rw [mem_unwrap, mem_singleton] + cases hs : Path.stripPrefix p w with + | none => + have hn := (Path.stripPrefix_eq_none p w).mp hs + exact ⟨fun e => absurd e.symm (hn q), fun h => absurd h (not_mem_empty q)⟩ + | some r => + have := (Path.stripPrefix_eq_some p w r).mp hs; subst this + rw [mem_singleton, List.append_cancel_left_eq] + +/-- line 134: `drop-prefix ε` -/ +theorem dropPrefix_eps (w : Path) : unwrap (singleton w) [] = singleton w := by + rw [unwrap_singleton]; rfl +/-- line 136: the exact case -/ +theorem dropPrefix_self (p : Path) : unwrap (singleton p) p = singleton [] := by + rw [unwrap_singleton, PZip.stripPrefix_self] +/-- line 138: the proper-prefix case -/ +theorem dropPrefix_append (p r : Path) : unwrap (singleton (p ++ r)) p = singleton r := by + rw [unwrap_singleton, Path.stripPrefix_append] +/-- line 140: the descend case -/ +theorem dropPrefix_descend (p q r : Path) : + unwrap (singleton (p ++ r)) (p ++ q) = unwrap (singleton r) q := by + rw [← unwrap_unwrap, dropPrefix_append] +/-- lines 142–153: every miss — the prefix is not a prefix of the path. -/ +theorem dropPrefix_miss {w p : Path} (h : ∀ r, w ≠ p ++ r) : unwrap (singleton w) p = empty := by + rw [unwrap_singleton, (Path.stripPrefix_eq_none p w).mpr h] +/-- lines 142 and 144: an item, or an item-headed path, misses `ε`. -/ +theorem dropPrefix_miss_eps (a : UInt8) (p : Path) : unwrap (singleton []) (a :: p) = empty := + dropPrefix_miss (fun r h => by simp at h) +/-- lines 146–152: differing first items miss. -/ +theorem dropPrefix_miss_item {a b : UInt8} (h : a ≠ b) (p r : Path) : + unwrap (singleton (b :: r)) (a :: p) = empty := + dropPrefix_miss (fun r' e => by simp at e; exact h e.1.symm) + +/-! ## 6. Composition (lines 155–160) + +No `pathmap` operation computes it in one step; the program `descend_to`s each +path of the left operand and `join_map_into`s the right one there. -/ + +section Composition +variable (s t u : Space) + +/-- line 155 -/ +theorem empty_composition : composition empty t = empty := ext fun p => by + rw [mem_composition] + exact ⟨fun ⟨_, _, _, h, _⟩ => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty p)⟩ +/-- line 156 -/ +theorem composition_empty : composition s empty = empty := ext fun p => by + rw [mem_composition] + exact ⟨fun ⟨_, _, _, _, h⟩ => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty p)⟩ +/-- line 157 -/ +theorem union_composition : composition (union s t) u = union (composition s u) (composition t u) := + ext fun p => by + simp only [mem_composition, mem_union] + constructor + · rintro ⟨a, b, rfl, ha | ha, hb⟩ + · exact Or.inl ⟨a, b, rfl, ha, hb⟩ + · exact Or.inr ⟨a, b, rfl, ha, hb⟩ + · rintro (⟨a, b, rfl, ha, hb⟩ | ⟨a, b, rfl, ha, hb⟩) + · exact ⟨a, b, rfl, Or.inl ha, hb⟩ + · exact ⟨a, b, rfl, Or.inr ha, hb⟩ +/-- line 158 -/ +theorem composition_union : composition s (union t u) = union (composition s t) (composition s u) := + ext fun p => by + simp only [mem_composition, mem_union] + constructor + · rintro ⟨a, b, rfl, ha, hb | hb⟩ + · exact Or.inl ⟨a, b, rfl, ha, hb⟩ + · exact Or.inr ⟨a, b, rfl, ha, hb⟩ + · rintro (⟨a, b, rfl, ha, hb⟩ | ⟨a, b, rfl, ha, hb⟩) + · exact ⟨a, b, rfl, ha, Or.inl hb⟩ + · exact ⟨a, b, rfl, ha, Or.inr hb⟩ +/-- line 160 -/ +theorem singleton_composition (p : Path) : composition (singleton p) t = wrap p t := ext fun q => by + simp only [mem_composition, mem_wrap, mem_singleton] + constructor + · rintro ⟨a, b, rfl, rfl, hb⟩; exact ⟨b, rfl, hb⟩ + · rintro ⟨b, rfl, hb⟩; exact ⟨p, b, rfl, rfl, hb⟩ +/-- line 159 -/ +theorem singleton_union_composition (p : Path) : + composition (union (singleton p) s) t = union (wrap p t) (composition s t) := by + rw [union_composition, singleton_composition] + +end Composition + +/-! ## 7. Tails, head, restriction, raffination (lines 162–198) + +`TailsUnion` and `TailsIntersection` fold `join_map_into` and `meet_into` over +`child_mask`; `Head` reads `child_mask` alone. egg's `tails-intersection` rules +(171–182) are a fold over an enumeration of the heads, and +`tailsInter_eq_foldl` is that fold for *any* enumeration, in any order, with +repeats. -/ + +/-- line 162 -/ +theorem tailsUnion_empty : tailsUnion empty = empty := ext fun p => by + rw [mem_tailsUnion] + exact ⟨fun ⟨_, h⟩ => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty p)⟩ +/-- line 164 -/ +theorem tailsUnion_eps : tailsUnion (singleton []) = empty := ext fun p => by + rw [mem_tailsUnion] + simp only [mem_singleton, reduceCtorEq, exists_false, false_iff] + exact not_mem_empty p +/-- line 166 -/ +theorem tailsUnion_cons (h : UInt8) (t : Path) : tailsUnion (singleton (h :: t)) = singleton t := + ext fun p => by + simp only [mem_tailsUnion, mem_singleton, List.cons.injEq] + exact ⟨fun ⟨_, _, e⟩ => e, fun e => ⟨h, rfl, e⟩⟩ +/-- line 165 -/ +theorem tailsUnion_item (h : UInt8) : tailsUnion (singleton [h]) = singleton [] := tailsUnion_cons h [] +/-- line 167 -/ +theorem tailsUnion_union (s t : Space) : tailsUnion (union s t) = union (tailsUnion s) (tailsUnion t) := + ext fun p => by + simp only [mem_tailsUnion, mem_union] + constructor + · rintro ⟨b, h | h⟩ + · exact Or.inl ⟨b, h⟩ + · exact Or.inr ⟨b, h⟩ + · rintro (⟨b, h⟩ | ⟨b, h⟩) + · exact ⟨b, Or.inl h⟩ + · exact ⟨b, Or.inr h⟩ +/-- line 169 -/ +theorem tailsUnion_wrap (a : UInt8) (s : Space) : tailsUnion (wrap [a] s) = s := ext fun p => by + simp only [mem_tailsUnion, mem_wrap, List.singleton_append, List.cons.injEq] + exact ⟨fun ⟨_, _, ⟨_, e⟩, h⟩ => e ▸ h, fun h => ⟨a, p, ⟨rfl, rfl⟩, h⟩⟩ +/-- line 168 -/ +theorem tailsUnion_wrap_union (a : UInt8) (s t : Space) : + tailsUnion (union (wrap [a] s) t) = union s (tailsUnion t) := by + rw [tailsUnion_union, tailsUnion_wrap] + +/-- The head enumerations egg's fold may use: a list naming each head at least +once and nothing else. -/ +def EnumHeads (x : Space) (hs : List UInt8) : Prop := ∀ c, c ∈ hs ↔ [c] ∈ head x + +theorem enumHeads_iff {x : Space} {hs : List UInt8} : + EnumHeads x hs ↔ ∀ c, c ∈ hs ↔ ∃ r, c :: r ∈ x := by + unfold EnumHeads + simp only [mem_head, List.cons.injEq, and_true] + constructor + · intro h c; rw [h c]; exact ⟨fun ⟨_, r, rfl, hr⟩ => ⟨r, hr⟩, fun ⟨r, hr⟩ => ⟨c, r, rfl, hr⟩⟩ + · intro h c; rw [h c]; exact ⟨fun ⟨r, hr⟩ => ⟨c, r, rfl, hr⟩, fun ⟨_, r, rfl, hr⟩ => ⟨r, hr⟩⟩ + +/-- line 173: no heads, no tails. -/ +theorem tailsInter_of_head_empty {x : Space} (h : head x = empty) : tailsInter x = empty := + ext fun p => by + rw [mem_tailsInter] + refine ⟨fun ⟨⟨b, r, hr⟩, _⟩ => ?_, fun h' => absurd h' (not_mem_empty p)⟩ + have : [b] ∈ head x := mem_head.mpr ⟨b, r, rfl, hr⟩ + rw [h] at this; exact absurd this (not_mem_empty _) + +/-- lines 177–182: egg's accumulating fold, `tails-intersection-acc`, over any +enumeration `h :: rest` of the heads. -/ +theorem tailsInter_eq_foldl {x : Space} {h : UInt8} {rest : List UInt8} + (he : EnumHeads x (h :: rest)) : + tailsInter x = rest.foldl (fun acc c => inter acc (unwrap x [c])) (unwrap x [h]) := by + have he' := enumHeads_iff.mp he + apply ext; intro p + rw [mem_tailsInter, mem_foldl_inter (fun c => unwrap x [c]), mem_unwrap] + simp only [mem_unwrap, List.singleton_append] + constructor + · rintro ⟨_, hall⟩ + exact ⟨hall h ((he' h).mp List.mem_cons_self), + fun c hc => hall c ((he' c).mp (List.mem_cons_of_mem _ hc))⟩ + · rintro ⟨h0, hall⟩ + refine ⟨⟨h, (he' h).mp List.mem_cons_self⟩, fun c hc => ?_⟩ + rcases List.mem_cons.mp ((he' c).mpr hc) with rfl | hc' + · exact h0 + · exact hall c hc' + +/-- line 175: one head. -/ +theorem tailsInter_of_head_singleton {x : Space} {h : UInt8} (hh : head x = singleton [h]) : + tailsInter x = unwrap x [h] := by + rw [tailsInter_eq_foldl (rest := [])] + · rfl + · intro c; rw [hh, mem_singleton]; simp + +/-- line 184 -/ +theorem restriction_empty_left (y : Space) : restriction empty y = empty := ext fun p => by + rw [mem_restriction]; exact ⟨fun h => h.1, fun h => absurd h (not_mem_empty p)⟩ +/-- line 185 -/ +theorem restriction_empty_right (x : Space) : restriction x empty = empty := ext fun p => by + rw [mem_restriction] + exact ⟨fun ⟨_, _, _, _, h⟩ => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty p)⟩ +/-- line 186 -/ +theorem restriction_eps (x : Space) : restriction x (singleton []) = x := ext fun p => by + rw [mem_restriction] + exact ⟨fun h => h.1, fun h => ⟨h, [], p, rfl, mem_singleton.mpr rfl⟩⟩ +/-- line 187 -/ +theorem restriction_union (x p q : Space) : + restriction x (union p q) = union (restriction x p) (restriction x q) := ext fun r => by + simp only [mem_restriction, mem_union] + constructor + · rintro ⟨hx, a, b, rfl, ha | ha⟩ + · exact Or.inl ⟨hx, a, b, rfl, ha⟩ + · exact Or.inr ⟨hx, a, b, rfl, ha⟩ + · rintro (⟨hx, a, b, rfl, ha⟩ | ⟨hx, a, b, rfl, ha⟩) + · exact ⟨hx, a, b, rfl, Or.inl ha⟩ + · exact ⟨hx, a, b, rfl, Or.inr ha⟩ +/-- line 188 -/ +theorem restriction_singleton (x : Space) (p : Path) : + restriction x (singleton p) = wrap p (unwrap x p) := ext fun q => by + simp only [mem_restriction, mem_wrap, mem_unwrap, mem_singleton] + constructor + · rintro ⟨hx, a, b, rfl, rfl⟩; exact ⟨b, rfl, hx⟩ + · rintro ⟨b, rfl, hx⟩; exact ⟨hx, p, b, rfl, rfl⟩ +/-- line 197: every path of `x` has itself as a prefix. -/ +theorem restriction_self (x : Space) : restriction x x = x := ext fun p => by + rw [mem_restriction]; exact ⟨fun h => h.1, fun h => ⟨h, p, [], by simp, h⟩⟩ + +/-- line 190 -/ +theorem head_empty : head empty = empty := ext fun p => by + rw [mem_head] + exact ⟨fun ⟨_, _, _, h⟩ => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty p)⟩ +/-- line 191 -/ +theorem head_eps : head (singleton []) = empty := ext fun p => by + rw [mem_head] + simp only [mem_singleton, reduceCtorEq, and_false, exists_false, false_iff] + exact not_mem_empty p +/-- line 192 -/ +theorem head_union (x y : Space) : head (union x y) = union (head x) (head y) := ext fun p => by + simp only [mem_head, mem_union] + constructor + · rintro ⟨b, r, rfl, h | h⟩ + · exact Or.inl ⟨b, r, rfl, h⟩ + · exact Or.inr ⟨b, r, rfl, h⟩ + · rintro (⟨b, r, rfl, h⟩ | ⟨b, r, rfl, h⟩) + · exact ⟨b, r, rfl, Or.inl h⟩ + · exact ⟨b, r, rfl, Or.inr h⟩ +/-- line 193 -/ +theorem head_cons (h : UInt8) (t : Path) : head (singleton (h :: t)) = singleton [h] := ext fun p => by + simp only [mem_head, mem_singleton, List.cons.injEq] + exact ⟨fun ⟨_, _, e, rfl, _⟩ => e, fun e => ⟨h, t, e, rfl, rfl⟩⟩ +/-- line 194 -/ +theorem head_item (h : UInt8) : head (singleton [h]) = singleton [h] := head_cons h [] + +/-- line 198: raffination is *defined* as `x \ (x <| y)`. -/ +theorem raffination_def (x y : Space) : raffination x y = subtr x (restriction x y) := rfl +/-- line 198's consequence. -/ +theorem raffination_self (x : Space) : raffination x x = empty := by + rw [raffination_def, restriction_self, subtr_self] + +/-! ## 8. Iteration (lines 202–242) + +`IterC` is `Iter` with a body that ignores its arguments, so its rules are +instances of `Iter`'s. egg's comment on rule L2 makes a point worth keeping: +`IterH` distributes over a union of its *head set*, with the source held fixed; +`Iter` does **not** distribute over a union of its *source*, because a head +shared by the two operands merges their groups and the body sees the merge. +`iter_not_union_source` is that refutation (egg's N05). -/ + +/-- line 239 (L1) -/ +theorem iter_def (src : Space) (body : UInt8 → Space → Space) : + iter src body = iterH (head src) src body := rfl +/-- line 240 (L4) -/ +theorem iterH_empty (src : Space) (body : UInt8 → Space → Space) : iterH empty src body = empty := + ext fun p => by + rw [mem_iterH] + exact ⟨fun ⟨_, h, _⟩ => absurd h (not_mem_empty _), fun h => absurd h (not_mem_empty p)⟩ +/-- line 241 (L2) -/ +theorem iterH_union (a c src : Space) (body : UInt8 → Space → Space) : + iterH (union a c) src body = union (iterH a src body) (iterH c src body) := ext fun p => by + simp only [mem_iterH, mem_union] + constructor + · rintro ⟨h, ha | ha, hp⟩ + · exact Or.inl ⟨h, ha, hp⟩ + · exact Or.inr ⟨h, ha, hp⟩ + · rintro (⟨h, ha, hp⟩ | ⟨h, ha, hp⟩) + · exact ⟨h, Or.inl ha, hp⟩ + · exact ⟨h, Or.inr ha, hp⟩ +/-- line 242 (L3) -/ +theorem iterH_item (h : UInt8) (src : Space) (body : UInt8 → Space → Space) : + iterH (singleton [h]) src body = body h (unwrap src [h]) := ext fun p => by + simp only [mem_iterH, mem_singleton, List.cons.injEq, and_true] + exact ⟨fun ⟨_, e, hp⟩ => e ▸ hp, fun hp => ⟨h, rfl, hp⟩⟩ + +/-- N05: iteration does not distribute over a union of its source. `a` and `c` +share the head `1`; the body asks whether its group holds both `[0]` and `[1]`, +which only the merged group does. -/ +theorem iter_not_union_source : + ¬ ∀ (a c : Space) (body : UInt8 → Space → Space), + iter (union a c) body = union (iter a body) (iter c body) := by + intro hall + let body : UInt8 → Space → Space := fun _ g => if [0] ∈ g ∧ [1] ∈ g then singleton [] else empty + have e := hall (singleton [1, 0]) (singleton [1, 1]) body + have hl : [] ∈ iter (union (singleton [1, 0]) (singleton [1, 1])) body := by + rw [mem_iter] + refine ⟨1, ⟨[0], mem_union.mpr (Or.inl (mem_singleton.mpr rfl))⟩, ?_⟩ + have h0 : [0] ∈ unwrap (union (singleton [1, 0]) (singleton [1, 1])) [1] := + mem_unwrap.mpr (mem_union.mpr (Or.inl (mem_singleton.mpr rfl))) + have h1 : [1] ∈ unwrap (union (singleton [1, 0]) (singleton [1, 1])) [1] := + mem_unwrap.mpr (mem_union.mpr (Or.inr (mem_singleton.mpr rfl))) + show [] ∈ (if _ then _ else _) + rw [if_pos ⟨h0, h1⟩]; exact mem_singleton.mpr rfl + have hr : [] ∉ union (iter (singleton [1, 0]) body) (iter (singleton [1, 1]) body) := by + rw [mem_union, mem_iter, mem_iter] + rintro (⟨h, _, hp⟩ | ⟨h, _, hp⟩) + · show False + revert hp; show [] ∈ (if _ then _ else _) → False + rw [if_neg] + · exact not_mem_empty _ + · rintro ⟨_, h1⟩ + have := mem_singleton.mp (mem_unwrap.mp h1); simp at this + · show False + revert hp; show [] ∈ (if _ then _ else _) → False + rw [if_neg] + · exact not_mem_empty _ + · rintro ⟨h0, _⟩ + have := mem_singleton.mp (mem_unwrap.mp h0); simp at this + exact hr (e ▸ hl) + +/-- line 204 -/ +theorem iterC_empty (b : Space) : iterC empty b = empty := by + rw [iterC, iter_def, head_empty, iterH_empty] +/-- line 205: a `{ε}` source has no heads (the case egg's prover caught). -/ +theorem iterC_eps (b : Space) : iterC (singleton []) b = empty := by + rw [iterC, iter_def, head_eps, iterH_empty] +/-- line 207 -/ +theorem iterC_cons (h : UInt8) (t : Path) (b : Space) : iterC (singleton (h :: t)) b = b := by + rw [iterC, iter_def, head_cons, iterH_item] +/-- line 206 -/ +theorem iterC_item (h : UInt8) (b : Space) : iterC (singleton [h]) b = b := iterC_cons h [] b +/-- line 208: the source *does* distribute when the body cannot see its group. -/ +theorem iterC_union (s t b : Space) : iterC (union s t) b = union (iterC s b) (iterC t b) := + ext fun p => by + simp only [mem_iterC, mem_union] + constructor + · rintro ⟨⟨h, r, hr | hr⟩, hp⟩ + · exact Or.inl ⟨⟨h, r, hr⟩, hp⟩ + · exact Or.inr ⟨⟨h, r, hr⟩, hp⟩ + · rintro (⟨⟨h, r, hr⟩, hp⟩ | ⟨⟨h, r, hr⟩, hp⟩) + · exact ⟨⟨h, r, Or.inl hr⟩, hp⟩ + · exact ⟨⟨h, r, Or.inr hr⟩, hp⟩ + +/-! ## 9. Least fixpoints (lines 244–292) + +egg introduces `Fix i F` as a first-class term and *axiomatises* it with three +rules: it contains `i` (line 288), it contains `F` of itself (line 289), and it +is below every `c` that does both (Park induction, line 291). Those rules are a +definition, so here they are the fields of a predicate, `IsLeastPostFix`, and +egg's `⊑` is its own encoding, `Union a c = c`. + +What egg's comment argues and does not mechanise is that the executors compute +this: they iterate the *inflationary* operator `cur ↦ cur ∪ F cur` until it +stops changing, and when `F` is monotone the value it stops at is the least +post-fixpoint above `i`. `kleene_isLeastPostFix` proves that. Monotonicity is +used only for leastness, as egg's comment says. -/ + +/-- egg's `⊑`: `Union a b = b`. -/ +theorem union_eq_right_iff {a b : Space} : union a b = b ↔ ∀ p, p ∈ a → p ∈ b := by + constructor + · intro h p hp; rw [← h]; exact mem_union.mpr (Or.inl hp) + · intro h; exact ext fun p => by + rw [mem_union]; exact ⟨fun h' => h'.elim (h p) id, Or.inr⟩ + +/-- `X` is the least post-fixpoint of `F` above `i`: egg's `Fix i F`. -/ +structure IsLeastPostFix (i : Space) (F : Space → Space) (X : Space) : Prop where + /-- line 288: `Fix ⊒ init` -/ + init : union i X = X + /-- line 289: `Fix ⊒ F(Fix)` -/ + post : union (F X) X = X + /-- line 291: Park induction -/ + park : ∀ c, union i c = c → union (F c) c = c → union X c = c + +/-- The least post-fixpoint is unique, so `Fix i F` is well defined. -/ +theorem IsLeastPostFix.unique {i X Y : Space} {F : Space → Space} + (hX : IsLeastPostFix i F X) (hY : IsLeastPostFix i F Y) : X = Y := by + have h1 := union_eq_right_iff.mp (hX.park Y hY.init hY.post) + have h2 := union_eq_right_iff.mp (hY.park X hX.init hX.post) + exact ext fun p => ⟨h1 p, h2 p⟩ + +/-- line 287 and the tour's line 436: with the identity step, `Fix i (λX.X) = i`. -/ +theorem fix_self (i : Space) : IsLeastPostFix i id i where + init := union_idem i + post := union_idem i + park _ h _ := h + +/-- `F` preserves `⊑`. -/ +def Monotone (F : Space → Space) : Prop := ∀ a b, union a b = b → union (F a) (F b) = F b + +/-- The executors' loop: `cur := cur ∪ F(cur)`. -/ +def kleene (i : Space) (F : Space → Space) : Nat → Space + | 0 => i + | n + 1 => union (kleene i F n) (F (kleene i F n)) + +theorem init_le_kleene (i : Space) (F : Space → Space) : ∀ n p, p ∈ i → p ∈ kleene i F n + | 0, _, h => h + | n + 1, p, h => mem_union.mpr (Or.inl (init_le_kleene i F n p h)) + +/-- **The loop computes `Fix`.** When the inflationary iteration stops changing +and `F` is monotone, where it stopped is the least post-fixpoint above `i`. -/ +theorem kleene_isLeastPostFix {i : Space} {F : Space → Space} (hF : Monotone F) {n : Nat} + (hn : kleene i F (n + 1) = kleene i F n) : IsLeastPostFix i F (kleene i F n) where + init := union_eq_right_iff.mpr (init_le_kleene i F n) + post := by + rw [union_comm]; exact hn + park c hi hc := by + have hi' := union_eq_right_iff.mp hi + have hc' := union_eq_right_iff.mp hc + have key : ∀ m p, p ∈ kleene i F m → p ∈ c := by + intro m + induction m with + | zero => exact hi' + | succ m ih => + intro p hp + rcases mem_union.mp hp with h | h + · exact ih p h + · have hm := union_eq_right_iff.mp (hF _ _ (union_eq_right_iff.mpr ih)) + exact hc' p (hm p h) + exact union_eq_right_iff.mpr (key n) + +/-! ## 10. The raw zipper operations are the set operators + +`Refine.lean` says exactly what each write operation puts at its focus. Before +issue #104, `join_into`, `restrict`, `insert_prefix` and `join_k_path_into` +worked on the node below the focus and so missed the focus value, and +`meet_k_path_into` kept the focus value when its meet was empty. On this branch +each carries the focus value with the subtrie, and each is its egg operator +outright. -/ + +/-- `join_into` is `Union`. -/ +theorem joinInto_eq_union (a b : Space) : ((wz a).joinInto unitOps (wz b)).2.trie = union a b := by + rw [PZip.joinInto_eq _ unitOps_lawful, PZip.withTrie_trie, wz_focus, replaceAt_nil, wz_makeMap, + wz_makeMap, union_eq_join] + +/-- `restrict` is `Restriction` — by definition (§1), and `mem_restriction` is the +membership law egg states for it. -/ +theorem restrict_eq_restriction (x y : Space) : + ((wz x).restrict unitOps (wz y)).2.trie = restriction x y := rfl + +/-- `insert_prefix p` is `Wrap p`. -/ +theorem insertPrefix_eq_wrap (pre : Path) (s : Space) : ((wz s).insertPrefix pre).2.trie = wrap pre s := + ext fun p => by + rw [PZip.insertPrefix_eq, PZip.withTrie_trie, wz_focus, replaceAt_nil, wz_makeMap, mem_wrap, + mem_def, valAt_prepend] + cases hs : Path.stripPrefix pre p with + | none => + simp only [Option.isSome_none, Bool.false_eq_true, false_iff, not_exists, not_and] + intro r hr; exact absurd hr ((Path.stripPrefix_eq_none pre p).mp hs r) + | some r => + have := (Path.stripPrefix_eq_some pre p r).mp hs; subst this + constructor + · intro h; exact ⟨r, rfl, h⟩ + · rintro ⟨r', hr', h⟩ + rw [List.append_cancel_left hr']; exact h + +/-- The locations one byte down are the heads. -/ +theorem mem_kPaths_one {s : Space} {q : Path} : q ∈ s.kPaths 1 ↔ ∃ b r, q = [b] ∧ b :: r ∈ s := by + rw [kPaths, List.mem_filter, PrunedMap.paths, Path.mem_sortDedup] + constructor + · rintro ⟨hm, hl⟩ + have hl : q.length = 1 := by simpa using hl + rcases List.mem_cons.mp hm with rfl | hm + · cases hl + · obtain ⟨k, hk, hq⟩ := List.mem_flatMap.mp hm + obtain ⟨n, _, rfl⟩ := List.mem_map.mp hq + match k, n with + | [], _ => simp at hl + | _ :: _, 0 => simp at hl + | b :: r, n + 1 => + refine ⟨b, r, ?_, mem_keys.mp hk⟩ + simp only [List.take_succ_cons, List.length_cons, Nat.add_eq_right, + List.length_eq_zero_iff] at hl ⊢ + rw [hl] + · rintro ⟨b, r, rfl, h⟩ + refine ⟨List.mem_cons_of_mem _ (List.mem_flatMap.mpr ⟨b :: r, mem_keys.mpr h, ?_⟩), rfl⟩ + exact List.mem_map.mpr ⟨1, List.mem_range.mpr (by simp), rfl⟩ + +/-- `join_k_path_into 1` is `TailsUnion`. -/ +theorem joinKPathInto_one_eq_tailsUnion (s : Space) : + ((wz s).joinKPathInto unitOps 1).2.trie = tailsUnion s := ext fun p => by + rw [PZip.joinKPathInto_eq, if_neg (by decide), PZip.withTrie_trie, wz_focus, replaceAt_nil, + wz_makeMap, mem_tailsUnion, dropHead, if_neg (by decide)] + have hf : (fun acc q => join unitOps acc (s.subtrie q)) = (fun acc q => union acc (s.subtrie q)) := by + funext acc q; rw [union_eq_join] + rw [hf, mem_foldl_union (fun q => s.subtrie q), or_iff_right (show p ∉ (PrunedMap.empty : Space) from not_mem_empty p)] + constructor + · rintro ⟨q, hq, hp⟩ + obtain ⟨b, r, rfl, _⟩ := mem_kPaths_one.mp hq + refine ⟨b, ?_⟩ + rw [mem_def, valAt_subtrie] at hp; exact hp + · rintro ⟨b, h⟩ + refine ⟨[b], mem_kPaths_one.mpr ⟨b, p, rfl, h⟩, ?_⟩ + rw [mem_def, valAt_subtrie]; exact h + +theorem mem_meet {p : Path} {a b : Space} : p ∈ meet unitOps a b ↔ p ∈ a ∧ p ∈ b := by + rw [mem_def, unit_meet_isSome, Bool.and_eq_true]; rfl + +theorem foldl_meetStep_eq_none (s : Space) : ∀ (L : List Path) (acc : Option Space), + L.foldl (PZip.meetStep unitOps s []) acc = none ↔ acc = none ∧ L = [] + | [], acc => by simp + | q :: L, acc => by + rw [List.foldl_cons, foldl_meetStep_eq_none s L] + cases acc <;> simp [PZip.meetStep] + +theorem mem_foldl_meetStep (s : Space) (p : Path) : ∀ (L : List Path) (acc : Option Space) (M : Space), + L.foldl (PZip.meetStep unitOps s []) acc = some M → + (p ∈ M ↔ (∀ a, acc = some a → p ∈ a) ∧ ∀ q ∈ L, q ++ p ∈ s) + | [], acc, M, h => by + simp only [List.foldl_nil] at h; subst h + simp only [List.not_mem_nil, false_imp_iff, implies_true, and_true] + exact ⟨fun hp a ha => by cases ha; exact hp, fun h => h M rfl⟩ + | q :: L, acc, M, h => by + rw [List.foldl_cons] at h + rw [mem_foldl_meetStep s p L _ M h, List.forall_mem_cons] + have hq : p ∈ s.subtrie ([] ++ q) ↔ q ++ p ∈ s := by rw [mem_def, valAt_subtrie]; simp; rfl + cases acc with + | none => + simp only [PZip.meetStep, Option.some.injEq, forall_eq', reduceCtorEq, false_imp_iff, + implies_true, true_and] + rw [hq] + | some a0 => + simp only [PZip.meetStep, Option.some.injEq, forall_eq'] + rw [mem_meet, hq, and_assoc] + +/-- `meet_k_path_into 1` is `TailsIntersection`. -/ +theorem meetKPathInto_one_eq_tailsInter (s : Space) : + ((wz s).meetKPathInto unitOps 1).2.trie = tailsInter s := ext fun p => by + rw [PZip.meetKPathInto_snd, PZip.graftMap_eq, PZip.withTrie_trie, wz_focus, replaceAt_nil, + mem_tailsInter] + simp only [wz_trie] + rw [subtrie_nil] + cases h : (s.kPaths 1).foldl (PZip.meetStep unitOps s []) none with + | none => + have hL := ((foldl_meetStep_eq_none s _ _).mp h).2 + simp only [Option.getD_none] + refine ⟨fun hp => absurd hp (not_mem_empty p), ?_⟩ + rintro ⟨⟨b, r, hb⟩, _⟩ + have := mem_kPaths_one.mpr ⟨b, r, rfl, hb⟩ + rw [hL] at this; cases this + | some M => + simp only [Option.getD_some] + rw [mem_foldl_meetStep s p _ _ M h] + have hne : s.kPaths 1 ≠ [] := fun e => by + rw [e] at h; cases h + obtain ⟨q0, hq0⟩ := List.exists_mem_of_ne_nil _ hne + obtain ⟨b0, r0, -, hb0⟩ := mem_kPaths_one.mp hq0 + simp only [reduceCtorEq, false_imp_iff, implies_true, true_and] + constructor + · intro hall + refine ⟨⟨b0, r0, hb0⟩, fun b ⟨r, hr⟩ => ?_⟩ + exact hall [b] (mem_kPaths_one.mpr ⟨b, r, rfl, hr⟩) + · rintro ⟨_, hall⟩ q hq + obtain ⟨b, r, rfl, hr⟩ := mem_kPaths_one.mp hq + exact hall b ⟨r, hr⟩ + +/-! ## 11. The tour (lines 294–436) + +Every `(check (= a b))` is a `#guard a == b`, every `(fail (check …))` a +`#guard … != …`. Items are bytes; the letters are egg's `a..z = 10..35`. -/ + +section Tour + +private def it (a : UInt8) : Space := singleton [a] +private def expr1 := union (it 10) (it 11) +private def expr2 := wrap [18] expr1 +private def expr3 := union (singleton [18, 10]) (singleton [18, 11]) +private def expr4 := unwrap expr3 [18] +private def expr_qi : Path := [26, 18] +private def expr_qi_unwrap := unwrap (wrap expr_qi expr1) expr_qi +private def expr_unwrap_prefix := unwrap (singleton [10, 11]) [10] +private def expr_unwrap_exact := unwrap (singleton [10, 11]) [10, 11] +private def expr_unwrap_miss := unwrap (singleton [10]) [11] +private def expr1_ := union (it 33) (it 34) +private def expr_prod := composition expr1_ expr1 +private def expr_prod_expanded := + union (union (singleton [33, 10]) (singleton [33, 11])) (union (singleton [34, 10]) (singleton [34, 11])) +private def expr_tailsunion1 := tailsUnion expr_prod_expanded +private def expr_tailsintersection1 := tailsInter expr_prod_expanded +private def expr1_head := head expr1 +private def expr3_head := head expr3 +private def expr_prod_head := head expr_prod_expanded +private def expr_s0 := it 0 +private def expr_restriction_keys := + union (union (composition expr1 (it 0)) (composition (union (it 10) (union (it 12) (it 13))) (it 1))) + (composition (it 12) (it 2)) +private def expr_restriction := restriction expr_restriction_keys expr1 +private def expr_restriction_tailsintersection := tailsInter expr_restriction +private def expr_restriction_res1 := + union (union (singleton [10, 0]) (singleton [10, 1])) (singleton [11, 0]) +private def expr_restriction_multi := + restriction (union (wrap [10] (it 0)) (wrap [11] (it 1))) (union (it 10) (it 11)) +private def expr_restriction_multi_res := union (singleton [10, 0]) (singleton [11, 1]) +private def expr_restriction_multi_only_a := singleton [10, 0] +private def expr_tailsintersection_duplicate_heads := + tailsInter (union (union (wrap [10] (it 0)) (wrap [10] (it 1))) (wrap [11] (it 0))) +private def restr_self := restriction expr1 expr1 +private def raff_self := raffination expr1 expr1 +private def unwrap_chain := unwrap (unwrap (singleton [10, 11, 12]) [10]) [11] +private def wrap_unwrap_miss := unwrap (wrap [32] expr1) [10] +private def tails_single := tailsUnion (singleton [10, 11]) +private def iu_body := union (it 21) (it 27) +private def iu_orig_empty := iterC empty iu_body +private def iu_distr_empty := union (iterC empty (it 21)) (iterC empty (it 27)) +private def iu_hoist_empty := union (it 21) (iterC empty (it 27)) + +#guard expr2 == expr3 +#guard expr1 == expr4 +#guard expr_qi_unwrap == expr1 +#guard expr_unwrap_prefix == it 11 +#guard expr_unwrap_exact == singleton [] +#guard expr_unwrap_miss == empty +#guard expr_prod == expr_prod_expanded +#guard expr_tailsunion1 == expr1 +#guard expr_tailsintersection1 == expr1 +#guard expr_restriction == expr_restriction_res1 +#guard expr_restriction_tailsintersection == expr_s0 +#guard expr_restriction_multi == expr_restriction_multi_res +#guard expr_restriction_multi != expr_restriction_multi_only_a +#guard expr_tailsintersection_duplicate_heads == expr_s0 +#guard expr_tailsintersection_duplicate_heads != empty +#guard restr_self == expr1 +#guard raff_self == empty +#guard unwrap_chain == it 12 +#guard wrap_unwrap_miss == empty +#guard tails_single == it 11 +#guard expr1_head == expr1 +#guard expr3_head == it 18 +#guard expr_prod_head == expr1_ +#guard iu_orig_empty == empty +#guard iu_orig_empty == iu_distr_empty +#guard iu_orig_empty != iu_hoist_empty + +/-- The tour's step `F(X) = X ∪ {b}` (line 391). -/ +private def step900 (x : Space) : Space := union x (it 11) + +private theorem step900_mono : Monotone step900 := by + intro a b h + rw [union_eq_right_iff] at h ⊢ + intro p hp + simp only [step900, mem_union] at hp ⊢ + exact hp.elim (fun h' => Or.inl (h p h')) Or.inr + +/-- line 434: `Fix({a,b}, X ↦ X ∪ {b}) = {a,b}`, as the executors' loop reaches it. -/ +theorem fix_ab : IsLeastPostFix expr1 step900 expr1 := by + have h : kleene expr1 step900 1 = kleene expr1 step900 0 := by + show union expr1 (union expr1 (it 11)) = expr1 + rw [← union_assoc, union_idem, union_comm, union_eq_right_iff] + intro p hp; exact mem_union.mpr (Or.inr (mem_singleton.mp hp ▸ mem_singleton.mpr rfl)) + exact kleene_isLeastPostFix step900_mono h + +/-- line 435: `{a}` is not it — Park must not fire there, because `{a}` is not +above the initial value. -/ +theorem fix_not_too_small : ¬ IsLeastPostFix expr1 step900 (it 10) := by + intro h + have := fix_ab.unique h + have hb : [11] ∈ expr1 := mem_union.mpr (Or.inr (mem_singleton.mpr rfl)) + rw [this] at hb + exact absurd (mem_singleton.mp hb) (by decide) + +end Tour + +end Zippy +end PrunedModel diff --git a/lean/README.md b/lean/README.md index c04d51be..f317bd5a 100644 --- a/lean/README.md +++ b/lean/README.md @@ -36,8 +36,16 @@ cargo build --release -p differential # generate random programs and compare model against crate ./lean/differential.py --random 500 --seed 1 +# the same, for the dangling-path-free subset (the second model, below) +./lean/pruned_differential.py --random 500 --seed 1 + # minimise an input that diverges (or that panics) ./lean/shrink.py path/to/input.bin + +# ...or one that diverges against the second model +PATHMAP_ORACLE=lean/.lake/build/bin/pruned-oracle \ +PATHMAP_TRACE=target/release/pruned_trace \ + ./lean/shrink.py path/to/input.bin ``` `lake build` also checks every `#guard` in `PathMapModel/Check.lean`, so a build @@ -155,6 +163,8 @@ focus, such that ..." — instead of as a node walk. | `PathMapModel/Check.lean` | `#guard`s: regression fixtures transcribed from `src/write_zipper.rs`'s own tests, and the §2 laws over a battery of tries | | `PathMapModel/Fuzz.lean` | the wire format, the operation table, and the trace producer (including `--act` mode) | | `Main.lean` | the `pathmap-oracle` binary | +| `PrunedModel/*.lean` | the second model — the same API over `List (Path × V)`, covering only the subset that cannot leave a dangling path; see below | +| `PrunedMain.lean` | the `pruned-oracle` binary | ## What is proved versus what is checked @@ -367,9 +377,7 @@ skips diverges: | token | what it means | |---|---| -| `skip:k0` | `meet_k_path_into(0)`, `join_k_path_into(0)` — degenerate; they should be the identity and destroy the subtrie. (`descend_first_k_path(0)` is specified as `false` without moving and is no longer skipped.) | -| `skip:empty-focus` | `meet_k_path_into` with no children (it does not terminate), and `restricting` when either side has nothing below its focus (the two branches differ in *effect*, not just in the reported bool). | -| `skip:empty-path` | `insert_prefix("")` — should be the identity, destroys the subtrie. | +| `skip:empty-focus` | `restricting` when either side has nothing below its focus (the two branches differ in *effect*, not just in the reported bool). | | `skip:at-root` | `to_next_sibling_byte` / `to_prev_sibling_byte` at the zipper root — the native read zipper leaves its own root there. | | `skip:quarantined` | `graft_child_maps` (op 54), disabled outright: it is broken three ways (FINDINGS.md #15) and the node representations it leaves behind degrade the `AlgebraicStatus` that *later* operations report. | | `skip:act` | ACT mode only — the read source cannot be a merge source (`ZipperInfallibleSubtries` is not implemented for it) or does not implement the trait the op needs. | @@ -647,6 +655,134 @@ invariants in-process after every operation — no oracle needed: `differential.py` runs without `--check`, because a crate that violates an invariant should show up as a trace diff rather than as an abort. +## A second model: the dangling-path-free subset + +`PrunedModel` is a separate specification of the same crate, and the thing worth +understanding about it is why there are two. + +This model represents a trie as `List (Path × Option V)`. The `Option` is not +optional: `pathmap` locations really do come in three states — absent, +present-without-a-value, valued — and `create_path` makes the middle one on +purpose while `remove_val(false)` leaves it behind. A model that could not +represent it could not specify those operations. + +But that third state is also where most of the specification's difficulty lives. +`subtract` needs a rule of its own for it ("where the source has no node at all, +keep `self`'s subtree verbatim, *including its dangling paths*"), every algebraic +operation has to say which valueless locations survive it, and the `prune` flag +has to be pinned to `false` and compared against nothing, because its effect is +a function of where an internal node boundary happens to fall rather than of the +trie. Several of the findings are about nothing else. + +`PrunedModel` takes the other branch. It covers **only the subset of the API +that cannot produce a dangling path**, and in exchange drops the `Option`: + +```lean +structure PrunedMap (V : Type) where + entries : List (Path × V) +``` + +A location exists iff some key has it as a prefix. Existence is *derived*, not +stored, so a dangling path is not merely absent from the model — it is +unrepresentable. There is no third state to specify, no flag to thread, and +`subtract` is pointwise, because with nothing valueless to preserve, "keep +`self`'s subtree verbatim" and "subtract pointwise" coincide. + +The claim is correspondingly stronger. Where `PathMapModel` says *here is what +the crate does with dangling paths*, `PrunedModel` says *these operations never +make one* — so a trace divergence is either a wrong value or a location that +leads nowhere. `PrunedModel/Spec.lean` proves the claim (`no_dangling`, three +lines) and the corollary the fuzzer trades on: `prune_path` has nothing to do, so +the crate must report `0` for it. + +Three restrictions define the subset: + +1. **No `create_path`**, whose whole purpose is a location with no value. +2. **`prune = true` everywhere.** Removal here is inherently pruning, so there + is nothing to opt into; `prune_path` and `prune_ascend` stay in the operation + table as *assertions*. +3. **The write zipper is rooted at the map root.** One rooted below it holds a + node at its own root, which survives as a location leading nowhere once + everything beneath it is removed, and `prune_path` is documented not to rise + above the zipper's origin — so that is outside the model by construction + rather than by a bug. Off-root *writing* is still covered: the root-rooted + zipper reaches every focus with `descend_to`. + +Operations the subset covers are specified, not skipped, even where the crate is +known to leak. That is the point: `graft` with an empty source is accidentally +`create_path`, and +[PRUNED_FINDINGS.md](PRUNED_FINDINGS.md) is the result. Only two `skip:` +reasons survive (`at-root`, `empty-focus`), against the other harness's four. + +`differential/src/pruned.rs` is the crate side — one read source, so no +`ReadSource` trait and no ACT mode — and `lean/pruned_differential.py` is +`differential.py` with `ORACLE`, `TRACE_CANDIDATES` and `KNOWN` repointed, so +nothing about *how* inputs are run is duplicated. `pruned_trace --check` needs +no oracle at all: it asserts the zipper invariants after every operation and, +at the end, that the write target contains no dangling path. + +### Agreement + +4000 random programs, seed 11, against `pathmap` 0.4.0 at `ec818cf`: + +| | inputs | +| --- | --- | +| agree | 3005 | +| the two findings in `PRUNED_FINDINGS.md` | 901 | +| two classes shared with the other model (value bias, `Identity` not reported) | 94 | +| anything else | **0** | + +The same 4000 inputs with the harness built on `fuzz-fixes-v3`: that branch +fixes both of the classes this model inherited and neither of the two it found. +Which is the argument for having both models — `fuzz-fixes-v3` was driven by the +other one, and a model that *reproduces* dangling paths cannot report an +operation for making one. See +[PRUNED_FINDINGS.md](PRUNED_FINDINGS.md) §4, which also says which v3 columns +are spec drift rather than findings: v3 changes the k-path walk and the integer +`psubtract`, and this oracle is pinned to master's reading of both. + +### Zippy's set algebra, as zipper laws + +`PrunedModel/Zippy.lean` translates +[Zippy's `formal.egg`](https://github.com/Adam-Vandervorst/Zippy/blob/b/formal.egg) +— the reference semantics of a path-set algebra, given as egglog rewrite rules — +into theorems about this model's zippers, and proves every one of them. Over +`()` a `PrunedMap` *is* a finite set of paths, so each egg operator is defined as +a zipper program (`Union` is `join_map_into`, `Unwrap` is `descend_to` then +`make_map`, `Head` reads `child_mask`, …) and each rule becomes an equation +between programs. The tour's `(check …)` lines are `#guard`s. + +Two files underneath carry it. `Pointwise.lean` says what every `Map.lean` +operation holds at each path. `Refine.lean` proves, for the write operations, +that each one replaces the focus's subtrie with a named map and changes nothing +else — `meet_into` writes `meet z.make_map src.make_map`, and so on. + +With `focus_value_consistency` (issue #104) a subtrie includes its root value, +and the five raw operations that used to differ from their egg operator at the +focus value now are it, proved in §10: `join_into` is `Union`, `restrict` is +`Restriction`, `insert_prefix p` is `Wrap p`, `join_k_path_into 1` is +`TailsUnion`, and `meet_k_path_into 1` is `TailsIntersection` (since `482c248`, +an empty meet clears the focus value instead of keeping it). + +### The two models agree on values + +`PrunedModel/Project.lean` proves that the models are the same specification +once dangling paths are forgotten. The projection `π t := PrunedMap.mk' t.vals` +loses no value lookup, for every `PathMapModel` trie. Every map operation +commutes with it, and so do these zipper write operations, for any `prune` flag: +`set_val`, `remove_val`, `create_path`, `graft`, `graft_map`, `graft_src_at`, +`remove_branches`, `take_map`, `remove_prefix`, `join_into`, `join_map_into`, +`meet_2` and `restrict`. `prune_path`, `insert_prefix`, `meet_into` and +`subtract_into` commute on a trie whose locations are prefix-closed, which every +trie the model builds is: `meet_into` and `subtract_into` now prune at the end, +possibly on the input trie, and `insert_prefix` asks whether the focus exists, +which the two models answer from locations and from values respectively. + +Four operations read dangling paths and cannot commute, and each has a +counterexample theorem: `child_mask`, `restricting` (a dangling-only source +erases the destination), `meet_k_path_into` (a dangling k-path is an empty +operand — `PRUNED_FINDINGS.md` #6) and the map `take_map` returns. + ## Out of scope `ZipperHead` and the concurrency story, `ProductZipper` / `PrefixZipper` / diff --git a/lean/lakefile.toml b/lean/lakefile.toml index 783f6a37..0acf8626 100644 --- a/lean/lakefile.toml +++ b/lean/lakefile.toml @@ -1,5 +1,5 @@ name = "pathmap-model" -defaultTargets = ["PathMapModel", "pathmap-oracle"] +defaultTargets = ["PathMapModel", "pathmap-oracle", "PrunedModel", "pruned-oracle"] [[lean_lib]] name = "PathMapModel" @@ -7,3 +7,13 @@ name = "PathMapModel" [[lean_exe]] name = "pathmap-oracle" root = "Main" + +# The dangling-path-free model: a second, independent specification covering +# only the subset of the API that cannot leave a dangling path. See +# PrunedModel/Map.lean. +[[lean_lib]] +name = "PrunedModel" + +[[lean_exe]] +name = "pruned-oracle" +root = "PrunedMain" diff --git a/lean/pruned-corpus/graft-empty-src-creates-dangling-focus.bin b/lean/pruned-corpus/graft-empty-src-creates-dangling-focus.bin new file mode 100644 index 00000000..0deb5347 Binary files /dev/null and b/lean/pruned-corpus/graft-empty-src-creates-dangling-focus.bin differ diff --git a/lean/pruned-corpus/graft_masked_branches-creates-dangling-child.bin b/lean/pruned-corpus/graft_masked_branches-creates-dangling-child.bin new file mode 100644 index 00000000..17c6e393 Binary files /dev/null and b/lean/pruned-corpus/graft_masked_branches-creates-dangling-child.bin differ diff --git a/lean/pruned-corpus/graft_masked_branches-creates-dangling-focus.bin b/lean/pruned-corpus/graft_masked_branches-creates-dangling-focus.bin new file mode 100644 index 00000000..eefd1db7 Binary files /dev/null and b/lean/pruned-corpus/graft_masked_branches-creates-dangling-focus.bin differ diff --git a/lean/pruned-corpus/graft_src_at-empty-src-creates-dangling-focus.bin b/lean/pruned-corpus/graft_src_at-empty-src-creates-dangling-focus.bin new file mode 100644 index 00000000..a70093f9 Binary files /dev/null and b/lean/pruned-corpus/graft_src_at-empty-src-creates-dangling-focus.bin differ diff --git a/lean/pruned-corpus/join_into-value-bias-by-node-layout.bin b/lean/pruned-corpus/join_into-value-bias-by-node-layout.bin new file mode 100644 index 00000000..c5f233fe Binary files /dev/null and b/lean/pruned-corpus/join_into-value-bias-by-node-layout.bin differ diff --git a/lean/pruned-corpus/join_map_into-status-element-when-unchanged.bin b/lean/pruned-corpus/join_map_into-status-element-when-unchanged.bin new file mode 100644 index 00000000..de1bdd74 Binary files /dev/null and b/lean/pruned-corpus/join_map_into-status-element-when-unchanged.bin differ diff --git a/lean/pruned-corpus/meet_2-empty-result-creates-dangling-focus.bin b/lean/pruned-corpus/meet_2-empty-result-creates-dangling-focus.bin new file mode 100644 index 00000000..8f777b0b Binary files /dev/null and b/lean/pruned-corpus/meet_2-empty-result-creates-dangling-focus.bin differ diff --git a/lean/pruned-corpus/remove_prefix-creates-dangling-chain.bin b/lean/pruned-corpus/remove_prefix-creates-dangling-chain.bin new file mode 100644 index 00000000..294bb6d2 Binary files /dev/null and b/lean/pruned-corpus/remove_prefix-creates-dangling-chain.bin differ diff --git a/lean/pruned-corpus/restrict-empty-result-creates-dangling-focus.bin b/lean/pruned-corpus/restrict-empty-result-creates-dangling-focus.bin new file mode 100644 index 00000000..1b5b0121 Binary files /dev/null and b/lean/pruned-corpus/restrict-empty-result-creates-dangling-focus.bin differ diff --git a/lean/pruned-corpus/restricting-creates-dangling-focus.bin b/lean/pruned-corpus/restricting-creates-dangling-focus.bin new file mode 100644 index 00000000..04ba1ff2 Binary files /dev/null and b/lean/pruned-corpus/restricting-creates-dangling-focus.bin differ diff --git a/lean/pruned_differential.py b/lean/pruned_differential.py new file mode 100755 index 00000000..fa9dbcb0 --- /dev/null +++ b/lean/pruned_differential.py @@ -0,0 +1,186 @@ +#!/usr/bin/env python3 +"""Differential runner for the dangling-path-free subset. + +Same driver as `differential.py` -- resident children, parallel workers, +timeouts, shrinkable failures -- pointed at the other model/harness pair: + + lean/.lake/build/bin/pruned-oracle PrunedModel (the oracle) + target/*/pruned_trace the real crate + + ./lean/pruned_differential.py --random 2000 -j8 + ./lean/pruned_differential.py pruned-corpus/* + +Everything about *how* inputs are run is inherited rather than copied: there is +one implementation of the resident-child protocol, the restart-on-wedge logic +and the input sourcing, and this file only says which binaries to run and which +divergences are already understood. `differential.py` reads `ORACLE`, +`TRACE_CANDIDATES` and `KNOWN` at call time, which is what makes that possible. + +## Why the KNOWN table starts almost empty + +`differential.py`'s table is large because its model reproduces `pathmap`'s +dangling-path behaviour, so the divergences left over are the subtle ones. This +model instead *forbids* dangling paths, so the first divergences it reports are +the operations that leak one -- which are the point, not noise. An entry gets +added here only once the leak is recorded in FINDINGS.md, so a new one cannot +hide behind it. +""" +import os +import sys + +sys.path.insert(0, os.path.dirname(os.path.abspath(__file__))) + +import re + +import differential as D + +ROOT = os.path.dirname(os.path.dirname(os.path.abspath(__file__))) + +D.ORACLE = os.path.join(ROOT, "lean", ".lake", "build", "bin", "pruned-oracle") +# PRUNED_TRACE overrides the search, for builds that live in another target dir. +D.TRACE_CANDIDATES = [os.environ.get("PRUNED_TRACE", "")] + [ + os.path.join(ROOT, "target", "release", "pruned_trace"), + os.path.join(ROOT, "target", "debug", "pruned_trace"), +] + +def _fields(line): + """The trace line's tokens, keyed by field name, per zipper. + + `0 graft ret=- W=01 o01 e1 v- c0 n0 f01 R=...` -> the W and R groups as + dicts, so a divergence can be asked which field moved. + """ + out = {} + for side in ("W", "R"): + m = re.search(r" %s=(\S+(?: \S+)*?)(?= [WR]=|$)" % side, line) + if not m: + return None + out[side] = { + (re.match(r"[A-Za-z]*", t).group(0) or t): t[len(re.match(r"[A-Za-z]*", t).group(0)):] + for t in m.group(1).split() + } + return out + + +def dangling_focus(a, b): + """The crate has locations the model does not, and none of them holds a value. + + The signature is that `e` and/or `c` moved *up* while `v` and `n` did not + move at all: `path_exists` became true, or `child_mask` gained a bit, without + a value appearing anywhere at or below the focus. So whatever the crate + created or kept leads nowhere. Both halves of + PRUNED_FINDINGS.md #1 and #2 land here -- the focus itself (`e0` -> `e1`) and + a child of it (`c0` -> `c1`), which is why the two are one entry in `KNOWN`. + + The operations that do this are the ones with no `prune` parameter to pass: + `graft`, `graft_src_at`, `graft_masked_branches`, `meet_2`, `restrict`, + `restricting`, `remove_prefix`. The ones that have one (`remove_val`, + `remove_branches`, `meet_into`, `subtract_into`) clean up correctly when it + is set, which is what this harness passes throughout. + """ + fa, fb = _fields(a), _fields(b) + if not fa or not fb: + return None + hit = False + for side in ("W", "R"): + xa, xb = fa[side], fb[side] + if xa == xb: + continue + moved = {k for k in set(xa) | set(xb) if xa.get(k) != xb.get(k)} + if not moved or not moved <= {"e", "c"}: + return None + # No value may appear: `v` at the focus and `n` below it must be equal, + # or the difference is content rather than an empty location. + if xa["v"] != xb["v"] or xa["n"] != xb["n"]: + return None + if "e" in moved and not (xa["e"] == "0" and xb["e"] == "1"): + return None + if "c" in moved and not int(xb["c"]) > int(xa["c"]): + return None + hit = True + return "DANGLING-FOCUS" if hit else None + + +def dangling_kept_dump(a, b): + """The crate's dump holds locations the model's does not, all valueless. + + The same defect seen in a trie dump rather than in a fingerprint: the model's + entries are a subsequence of the crate's, and every entry only the crate has + renders `-`. Nothing leads to those locations, so they are dangling paths + the operation declined to reclaim. + """ + ta, tb = a.split(), b.split() + if len(ta) != len(tb) or len(ta) < 2: + return None + if ta[0] != tb[0] or not (ta[0].startswith("MAP") or ta[1] == "dump"): + return None + sa, sb = ta[-1], tb[-1] + ea = [e for e in sa.split(",") if e] + eb = [e for e in sb.split(",") if e] + if len(eb) <= len(ea): + return None + # Is `ea` a subsequence of `eb`, and is every skipped entry valueless? + i, extra = 0, [] + for e in eb: + if i < len(ea) and e == ea[i]: + i += 1 + else: + extra.append(e) + if i != len(ea) or not extra: + return None + if any(not e.endswith(":-") for e in extra): + return None + return "DANGLING-DUMP" + + +_inherited_shape = D.divergence_shape + + +def divergence_shape(a, b): + """This model's shapes first, then the ones `differential.py` knows. + + Its shapes are about a model that *reproduces* dangling paths, so they + cannot name the class this one exists to report; they stay in place for + everything else. + """ + return dangling_focus(a, b) or dangling_kept_dump(a, b) or _inherited_shape(a, b) + + +D.divergence_shape = divergence_shape + +# Keyed on a substring of the divergence report, newest-understood first; see +# `differential.classify`. Each entry must name the operation *and* the +# finding, so that reading a `known` line tells you what was already decided. +D.KNOWN = [ + (["ESCAPED-ROOT"], + "a zipper left its own root: root_prefix_path() changed [root_escape]"), + # The trie-dump form, tested before the fingerprint form: a line that is + # only a dump has no fingerprint to read. + (["DANGLING-DUMP"], + "an empty write leaves locations that lead nowhere in the trie " + "(PRUNED_FINDINGS.md #1) [empty_write_materialises_focus]"), + # PRUNED_FINDINGS.md #1 and #2 -- one mechanism, seen at the focus (#1) or at + # a child of it (#2). Still present on fuzz-fixes-v3. + (["DANGLING-FOCUS"], + "an operation with no prune parameter materialises an empty location " + "(PRUNED_FINDINGS.md #1, #2) [empty_write_materialises_focus]"), + # The two classes this model shares with the other one. Both are live on + # master; `fuzz-fixes-v3` carries a fix for the value-bias one (3dae731). + # + # The STATUS-ONLY shape is two-directional and the direction is what names + # it, so read the report rather than the tag. `Identity` from the model + # against `Element` from the crate is the FINDINGS.md #8 imprecision in + # `subtract_into` and `meet_into`. The reverse direction appears only against + # fuzz-fixes-v3, whose `u64::psubtract` (f8a4599) returns Identity where + # `Basic.u64Ops` still says Element. + (["STATUS-ONLY"], + "AlgebraicStatus::Identity is not returned reliably when nothing changed, " + "in subtract_into/meet_into (FINDINGS.md #8)"), + (["VALUE-ONLY"], + "a value collision resolves to the counterpart, by node layout rather than " + "by path (FINDINGS.md value bias); fuzz-fixes-v3 fixes it with 3dae731"), +] + +if __name__ == "__main__": + if "--act" in sys.argv: + sys.exit("--act is meaningless here: there is one read source") + D.main()