Selkie.git | xt/ | 06-disabled-plane.rakutest
use Test;
use lib 'lib';
use Selkie::Sizing;
use Selkie::Style;
use Selkie::Test::Snapshot;
use Selkie::Widget;
use Notcurses::Native;
use Notcurses::Native::Channel;
use Notcurses::Native::Plane;
use Notcurses::Native::Types;
=begin pod
The half of C<Selkie::Widget>'s disabled support that needs a real
plane: what C<greyscale-plane> actually does to notcurses's cells.
Lives in C<xt/> because it initialises notcurses. C<t/96-disabled>
stays plane-free and covers the flag, the focus filtering and the
arithmetic; this file covers the seam between them and the library.
The load-bearing assertion is the second one: a cell that inherits a
channel keeps inheriting it. notcurses ships C<ncplane_greyscale>,
which does the whole plane in one native call — and flattens every
inherited channel to an explicit black on the way, because an inherited
channel reads back as C<0, 0, 0>. Selkie leans on inherited channels
everywhere (the C<text> theme slot sets no background; every unwritten
cell is inherited in both), so that call turns a disabled widget into a
black rectangle. Asserting the inherited channel survives here means
nobody can "simplify" C<greyscale-plane> back into the one-liner
without a red test.
=end pod
plan 6;
# Runs a block against a real, mounted, correctly-sized plane and hands
# back whatever the block recorded. render-to-string destroys the
# widget's plane afterwards; the recorded values outlive it.
class Probe does Selkie::Widget {
has &.body is required;
has @.log;
method render() {
return without self.plane;
@!log = &!body(self.plane, self);
self.clear-dirty;
}
}
sub on-plane(UInt $rows, UInt $cols, &body --> List) {
my $p = Probe.new(body => &body, sizing => Sizing.flex);
render-to-string($p, :$rows, :$cols);
$p.log.List;
}
# (channels, fg-default?, bg-default?) for one cell of a plane.
sub cell-at(NcplaneHandle $plane, Int $y, Int $x --> List) {
my uint16 $sm = 0;
my uint64 $ch = 0;
my $egc = ncplane_at_yx($plane, $y, $x, $sm, $ch);
($egc, $ch, ?ncchannels_fg_default_p($ch), ?ncchannels_bg_default_p($ch),
$sm.Int);
}
subtest 'a fully-coloured cell greys to the Rec. 601 values' => {
plan 4;
my @log = on-plane 1, 4, -> $plane, $w {
ncplane_set_fg_rgb($plane, 0x00FF00);
ncplane_set_bg_rgb($plane, 0x24243E);
ncplane_set_styles($plane, NCSTYLE_BOLD);
ncplane_putstr_yx($plane, 0, 0, 'A');
$w.greyscale-plane;
[cell-at($plane, 0, 0),];
};
my ($egc, $ch, $fg-def, $bg-def, $sm) = @log[0].List;
is $egc, 'A', 'the glyph is untouched — greying is a colour change';
is ncchannels_fg_rgb($ch), 0x959595, 'fg greyed (149, truncated)';
is ncchannels_bg_rgb($ch), 0x262626, 'bg greyed (38, truncated)';
is $sm, NCSTYLE_BOLD, 'the style mask survives';
};
subtest 'an INHERITED channel stays inherited, and does not go black' => {
plan 5;
# The regression this whole implementation exists for. Selkie's
# `text` slot sets a foreground and no background, so cells like
# this are the common case, not an edge case.
my @log = on-plane 1, 4, -> $plane, $w {
ncplane_set_fg_rgb($plane, 0x00FF00);
ncplane_set_bg_default($plane);
ncplane_putstr_yx($plane, 0, 0, 'A');
my @before = cell-at($plane, 0, 0);
$w.greyscale-plane;
[@before, cell-at($plane, 0, 0)];
};
my ($, $, $, $bg-def-before, $) = @log[0].List;
my ($egc, $ch, $fg-def, $bg-def, $) = @log[1].List;
ok $bg-def-before, 'the cell starts out inheriting its background';
is $egc, 'A', 'glyph intact';
nok $fg-def, 'the explicit foreground is still explicit';
is ncchannels_fg_rgb($ch), 0x959595, 'and greyed';
ok $bg-def,
'the inherited background is STILL inherited — not flattened to black';
};
subtest 'unwritten cells fall through to the greyed base cell' => {
plan 3;
my @log = on-plane 1, 8, -> $plane, $w {
# A base cell in the default theme's colours, then a single
# written cell — columns 1..7 stay unwritten.
ncplane_set_base($plane, ' ', 0,
Selkie::Style.new(fg => 0xC0C0C0, bg => 0x1A1A2E).channels);
ncplane_erase($plane);
ncplane_set_fg_rgb($plane, 0x00FF00);
ncplane_set_bg_rgb($plane, 0x00FF00);
ncplane_putstr_yx($plane, 0, 0, 'A');
$w.apply-disabled-effect;
my $base = Nccell.new;
ncplane_base($plane, $base);
[cell-at($plane, 0, 5), $base.channels];
};
my ($, $, $fg-def, $bg-def, $) = @log[0].List;
ok ($fg-def && $bg-def),
'an unwritten cell is left entirely inherited';
my $base-channels = @log[1];
is ncchannels_bg_rgb($base-channels), 0x1C1C1C,
'and the base cell it inherits from has been greyed';
is ncchannels_fg_rgb($base-channels), 0xC0C0C0,
'fg was already achromatic, so it is unchanged';
};
subtest 'double-width glyphs survive intact' => {
plan 4;
# Rewriting glyphs to recolour them would shift a wide glyph by a
# column (both halves report the same EGC). Staining channels in
# place cannot.
my @log = on-plane 1, 6, -> $plane, $w {
ncplane_set_fg_rgb($plane, 0x0000FF);
ncplane_set_bg_rgb($plane, 0xFF0000);
ncplane_putstr_yx($plane, 0, 0, '漢字');
$w.greyscale-plane;
[cell-at($plane, 0, 0), cell-at($plane, 0, 2)];
};
is @log[0].List[0], '漢', 'first wide glyph still at column 0';
is @log[1].List[0], '字', 'second still at column 2';
is ncchannels_fg_rgb(@log[0].List[1]), 0x1D1D1D, 'fg greyed (29)';
is ncchannels_bg_rgb(@log[0].List[1]), 0x4C4C4C, 'bg greyed (76)';
};
subtest 'alpha bits ride through untouched' => {
plan 3;
my @log = on-plane 1, 4, -> $plane, $w {
ncplane_set_fg_rgb($plane, 0x00FF00);
ncplane_set_bg_rgb($plane, 0x00FF00);
ncplane_set_bg_alpha($plane, NCALPHA_BLEND);
ncplane_putstr_yx($plane, 0, 0, 'A');
$w.greyscale-plane;
[cell-at($plane, 0, 0),];
};
my $ch = @log[0].List[1];
is ncchannels_bg_alpha($ch), NCALPHA_BLEND, 'a blended background stays blended';
is ncchannels_fg_alpha($ch), NCALPHA_OPAQUE, 'the opaque one stays opaque';
is ncchannels_bg_rgb($ch), 0x959595, 'and the colour still greys';
};
subtest 'greying is idempotent and safe on an empty plane' => {
plan 3;
my @log = on-plane 1, 4, -> $plane, $w {
ncplane_set_fg_rgb($plane, 0x7AA2F7);
ncplane_set_bg_rgb($plane, 0x24243E);
ncplane_putstr_yx($plane, 0, 0, 'A');
$w.greyscale-plane;
my $once = cell-at($plane, 0, 0)[1];
$w.greyscale-plane;
$w.greyscale-plane;
[$once, cell-at($plane, 0, 0)[1]];
};
is @log[1], @log[0],
'greying an already-grey plane changes nothing (the render post-pass '
~ 'can run every frame)';
is ncchannels_fg_rgb(@log[0]), 0x9F9F9F, 'and the first pass was correct';
# A plane that was erased and never written: every cell inherited,
# nothing to do, no crash.
my @empty = on-plane 2, 6, -> $plane, $w {
ncplane_erase($plane);
$w.greyscale-plane;
[cell-at($plane, 1, 4),];
};
ok (@empty[0].List[2] && @empty[0].List[3]),
'an all-inherited plane comes through untouched';
};