Selkie.git | t/ | 103-tree-prune.rakutest


use Test;
use lib 'lib';

use nqp;
use Selkie::Widget;
use Selkie::Container;
use Selkie::Tree;

=begin pod
C<mark-widgets-in-rect-dirty> runs once per sprixel teardown and walks
every widget of every tree root. In a long App::Cantina transcript
that is ~9.6k widgets of which ~95% are parked cards that cannot
intersect an on-screen rect — and dirtying them restarts the very
render that tore the sprixel down.

This file pins the prune (parked subtrees are skipped entirely), the
parity guarantee (an all-unparked tree behaves exactly as before), and
the C<is-parked> latch the prune reads.
=end pod

# Mocks that let us place widgets at arbitrary screen coordinates
# without a live notcurses plane. abs-y / abs-x / rows / cols are bound
# directly, the same technique t/62-tree-helpers uses.
class Plotted does Selkie::Widget {
    submethod TWEAK(:$abs-y = 0, :$abs-x = 0, :$rows = 0, :$cols = 0) {
        nqp::bindattr(self, Plotted, '$!abs-y', $abs-y.Int);
        nqp::bindattr(self, Plotted, '$!abs-x', $abs-x.Int);
        nqp::bindattr(self, Plotted, '$!rows',  $rows.UInt);
        nqp::bindattr(self, Plotted, '$!cols',  $cols.UInt);
    }
    method render() { self.clear-dirty }
}

class Group does Selkie::Widget {
    has @.children;
    submethod TWEAK(:$abs-y = 0, :$abs-x = 0, :$rows = 0, :$cols = 0,
                    :@children) {
        nqp::bindattr(self, Group, '$!abs-y', $abs-y.Int);
        nqp::bindattr(self, Group, '$!abs-x', $abs-x.Int);
        nqp::bindattr(self, Group, '$!rows',  $rows.UInt);
        nqp::bindattr(self, Group, '$!cols',  $cols.UInt);
        @!children = @children;
        $_.parent = self for @children;
    }
    method render() { self.clear-dirty }
}

# A Border-shaped node: its child hangs off .content, never .children.
class Wrapper does Selkie::Widget {
    has $.content is rw;
    submethod TWEAK(:$abs-y = 0, :$abs-x = 0, :$rows = 0, :$cols = 0) {
        nqp::bindattr(self, Wrapper, '$!abs-y', $abs-y.Int);
        nqp::bindattr(self, Wrapper, '$!abs-x', $abs-x.Int);
        nqp::bindattr(self, Wrapper, '$!rows',  $rows.UInt);
        nqp::bindattr(self, Wrapper, '$!cols',  $cols.UInt);
    }
    method render() { self.clear-dirty }
}

plan 8;

# --- The park latch ---------------------------------------------------

subtest 'is-parked tracks reposition through the park line' => {
    plan 5;
    my $w = Plotted.new;
    nok $w.is-parked, 'a fresh widget is not parked';

    $w.reposition($w.park-y, 0);
    ok $w.is-parked, 'repositioning to park-y latches parked';

    $w.reposition(3, 0);
    nok $w.is-parked, 'moving back into flow clears the latch';

    $w.park;
    ok $w.is-parked, 'park() latches through the same chokepoint';

    $w.reposition($w.park-y + 500, 0);
    ok $w.is-parked, 'anything at or past park-y counts as parked';
};

subtest 'Container.park latches the whole subtree' => {
    plan 4;
    my class Box does Selkie::Container { method render() { self.clear-dirty } }
    my $inner = Box.new;
    my $leaf  = Plotted.new;
    my $outer = Box.new;
    $inner.add($leaf);
    $outer.add($inner);

    $outer.park;
    ok $outer.is-parked, 'container latched';
    ok $inner.is-parked, 'nested container latched';
    ok $leaf.is-parked,  'leaf latched';

    $outer.reposition(0, 0);
    nok $outer.is-parked,
        'unparking the root clears the root latch (descendants ride its plane)';
};

# --- Pruning ----------------------------------------------------------

subtest 'a parked subtree is skipped even when its stale rect overlaps' => {
    plan 3;
    # This is the exact shape the prune exists for: a card scrolled out
    # of a ViewportedCardList is parked via park(), but nothing refreshes
    # its abs-y — it keeps the on-screen coordinates it last laid out at,
    # which happily overlap any rect in that region.
    my $parked-child = Plotted.new(:abs-y(5), :abs-x(5), :rows(4), :cols(8));
    my $parked = Group.new(
        :abs-y(5), :abs-x(5), :rows(4), :cols(8),
        children => [$parked-child]);
    my $live = Plotted.new(:abs-y(5), :abs-x(5), :rows(4), :cols(8));
    my $root = Group.new(
        :abs-y(0), :abs-x(0), :rows(100), :cols(100),
        children => [$parked, $live]);
    set-tree-roots-provider(-> { ($root,) });

    $parked.park;
    $_.clear-dirty for $root, $parked, $parked-child, $live;

    mark-widgets-in-rect-dirty(:abs-y(4), :abs-x(4), :rows(6), :cols(10));

    nok $parked.is-dirty,       'the parked node is not dirtied';
    nok $parked-child.is-dirty, 'nor is anything beneath it';
    ok  $live.is-dirty,         'its unparked sibling still is';
};

subtest 'unparking restores the walk' => {
    plan 2;
    my $child = Plotted.new(:abs-y(5), :abs-x(5), :rows(4), :cols(8));
    my $node = Group.new(:abs-y(5), :abs-x(5), :rows(4), :cols(8),
                         children => [$child]);
    set-tree-roots-provider(-> { ($node,) });

    $node.park;
    $_.clear-dirty for $node, $child;
    mark-widgets-in-rect-dirty(:abs-y(4), :abs-x(4), :rows(6), :cols(10));
    nok $node.is-dirty, 'parked: skipped';

    $node.reposition(0, 0);
    $_.clear-dirty for $node, $child;
    mark-widgets-in-rect-dirty(:abs-y(4), :abs-x(4), :rows(6), :cols(10));
    ok $child.is-dirty, 'unparked: walked again, descendants included';
};

subtest 'a parked root prunes the entire tree' => {
    plan 1;
    my $child = Plotted.new(:abs-y(1), :abs-x(1), :rows(4), :cols(8));
    my $root = Group.new(:abs-y(0), :abs-x(0), :rows(50), :cols(50),
                         children => [$child]);
    set-tree-roots-provider(-> { ($root,) });
    $root.park;
    $_.clear-dirty for $root, $child;
    mark-widgets-in-rect-dirty(:abs-y(0), :abs-x(0), :rows(10), :cols(10));
    nok $child.is-dirty, 'nothing under a parked root is dirtied';
};

# --- Parity with the pre-prune behaviour ------------------------------

subtest 'an all-unparked tree behaves exactly as before' => {
    plan 4;
    # Same assertions as t/62's intersection coverage, run through a
    # deeper tree so the recursion is exercised.
    my $in   = Plotted.new(:abs-y(5),  :abs-x(5),  :rows(4), :cols(8));
    my $out  = Plotted.new(:abs-y(50), :abs-x(50), :rows(4), :cols(8));
    my $mid  = Group.new(:abs-y(0), :abs-x(0), :rows(100), :cols(100),
                         children => [$in, $out]);
    my $root = Group.new(:abs-y(0), :abs-x(0), :rows(100), :cols(100),
                         children => [$mid]);
    set-tree-roots-provider(-> { ($root,) });
    $_.clear-dirty for $root, $mid, $in, $out;

    mark-widgets-in-rect-dirty(:abs-y(4), :abs-x(4), :rows(6), :cols(10));
    ok  $in.is-dirty,   'intersecting leaf marked';
    nok $out.is-dirty,  'distant leaf untouched';
    ok  $mid.is-dirty,  'enclosing intermediate marked';
    ok  $root.is-dirty, 'enclosing root marked';
};

subtest 'content-only children are still reached' => {
    plan 2;
    # Border / Modal hang their child off .content. The duck-typed
    # capability test has to keep finding it — and prune it when parked.
    my $inner = Plotted.new(:abs-y(5), :abs-x(5), :rows(4), :cols(8));
    my $wrap  = Wrapper.new(:abs-y(0), :abs-x(0), :rows(20), :cols(20));
    $wrap.content = $inner;
    set-tree-roots-provider(-> { ($wrap,) });

    $_.clear-dirty for $wrap, $inner;
    mark-widgets-in-rect-dirty(:abs-y(4), :abs-x(4), :rows(6), :cols(10));
    ok $inner.is-dirty, '.content child dirtied';

    $inner.park;
    $_.clear-dirty for $wrap, $inner;
    mark-widgets-in-rect-dirty(:abs-y(4), :abs-x(4), :rows(6), :cols(10));
    nok $inner.is-dirty, 'a parked .content child is pruned';
};

subtest 'children exposed without composing Container are still walked' => {
    plan 1;
    # Regression guard on the capability test itself: CardList and
    # ViewportedCardList override `children` but do NOT compose
    # Selkie::Container, so swapping the duck-type for a
    # `~~ Selkie::Container` check would silently walk past every card
    # in a list. Group here is deliberately a bare Selkie::Widget.
    nok Group ~~ Selkie::Container,
        'the mock exposes children without being a Container '
        ~ '(and the walk above still found its children)';
};

done-testing;