Source of termcol.plp

<(common.inc.plp)><:

if (my ($name) = $Request =~ /(.+)\.gpl\z/) {
	my $palettes = Data('termcol');
	my $palette = $palettes->{$name}
		or Abort("Palette '$name' not found", 404);
	ref $palette ne 'ARRAY'
		or Abort("Group contains multiple palettes: ".join(', ', @{$palette}));

	$header{content_type} = 'text/x-gimp-gpl';
	say 'GIMP Palette';
	say 'Name: ', $palette->{name} // $name;
	say 'Columns: 8';
	say '#';
	for (@{ $palette->{list} }) {
		my ($rgb, $name) = split /:/, $_, 3;
		say join ' ', unpack('C*', pack 'H6', $rgb), $name;
	}
	exit;
}

Html({
	title => ($Request ? 'terminal colour' : 'colour palettes') . ' cheat sheet',
	version => '1.4',
	description => [!$Request ? "Comparison of various colour palettes." : (
		"Index of all terminal/console colour codes,",
		"with an example result of various environments.",
	)],
	keywords => [qw'
		color colour code terminal console escape table xterm rxvt
		ansi vt100 8bit 4bit cga ega vga rgb hsv game emulator display
	'],
	data => ['termcol.inc.pl'],
	stylesheet => [qw'light dark'],
});

my @draw = map { [$_, s/\W+\z//] } grep { $_ } split m(/),
	$get{img} // exists $get{img} && 'compile.png';

my @termlist;
push @termlist, split /\W+/, $Request || 'default';

say "<h1>$_</h1>\n" for $Request ? 'Colour palettes' : 'Terminal colours';

say '<p>';
if ("@termlist" eq 'default') {
	say '<span title="ECMA-48">ANSI</span> (VT100, ISO-6429) 16-colour text palette';
	say 'as implemented by various systems and programs.';
	say 'Also see <a href="/termcol/legacy">8-bit legacy hardware</a> palettes.';
}
elsif ("@termlist" eq 'legacy') {
	say 'Colour palettes of various 8-bit legacy systems and retro games.';
	say 'Also see <a href="/termcol">ANSI console</a> palettes.';
}
else {
	say 'Comparison of requested colour palettes.';
}
:>

<div class="section">
<:
use Shiar_Sheet::Colour 1.04;
use List::Util qw( min max );
use POSIX qw( ceil );

my $palettes = Data('termcol');

sub colcell {
	my $name = shift // return "<td>\n";
	my $col = Shiar_Sheet::Colour->new(@_);
	my $minhex = $col->rgb24;
	my $css     = '#' . $col->rgb48;
	my $inverse = '#' . sprintf('%X', $col->luminance/255 < .3 ? 12 : 0) x 3;

	my $sample = [ qw(#000 #FFF) ];
	($name, $sample) = @$name if ref $name eq 'ARRAY';

	my $out = sprintf('<td title="%s" style="%s">%s',
		join(',', map { int } @$col),
		"background:$css; color:$inverse",
		$name,
	);
	$out .= sprintf('<samp style="%s"><small>%s</small></samp>',
		"background:$_; color:$css", $minhex
	) for @$sample;
	return "$out\n";
}

sub img_egapal {
	my ($palette, $imgfile, $reindex) = @_;
	return eval {
		require Imager;
		require MIME::Base64;

		my @imgpal = map { Imager::Color->new(ref $_ ? @$_ : $_) } @{$palette};
		state $imgcache = {};
		my $img = $imgcache->{$imgfile}
			//= Imager->new(file => "data/palimage/$imgfile")
			or die Imager->errstr.$/;

		do {
			if ($reindex) {
				$img->to_paletted({
					make_colors => 'none',
					colors => \@imgpal,
					translate => 'closest',
				});
			}
			else {
				@{[ $img->getcolors ]} == @imgpal
					or die "incompatible palette size\n";
				$img->setcolors(colors => \@imgpal);
				$img;
			}
		}->write(data => \my $imgdata, type => 'png');
		return sprintf '<img src="data:image/png;base64,%s">',
			MIME::Base64::encode_base64($imgdata);
	} || $@;
}

sub coltable {
	my ($term) = @_;
	my $info = $palettes->{$term};

	if (ref $info eq 'ARRAY') {
		coltable($_) for @{$info};
		return;
	}

	if (ref $info eq 'CODE') {
		coltable($_) for $info->($palettes);
		return;
	}

	ref $info eq 'HASH' or return;
	my $order = $get{order} && $get{order}.'order';
	my $reorder = $info->{$order} // $palettes->{ $info->{parent} }->{$order};

	my $caption = $info->{name} // $term;
	$caption = sprintf('<%s %s>%s</%1$s>',
		$info->{href} ? 'a' : 'span',
		join(' ',
			map { sprintf '%s="%s"', $_, $info->{$_} }
			grep { defined $info->{$_} }
			qw( href title )
		),
		$caption,
	) if $info->{href} or $info->{title};

	if ($info->{table} or $info->{rgbmap}) {
		say '<table class="color mapped">';
		say sprintf '<caption>%s</caption>', $caption;

		print coltable_hsv(@{$_}) for $info->{rgbmap} || ();

		if (my $table = $info->{table}) {
			$table = [ @{$table}[@{$reorder}] ] if $reorder;

			for my $row (@$table) {
				if (!$row) {
					say '<tbody>';
					next;
				}
				print '<tr>';
				print colcell(ref $_ ? @$_ : $_ ? reverse split /:/ : undef) for @$row;
			}

			if (@draw) {
				my $width = scalar @{ $table->[0] };
				my @imgpal = map {
					[ ref $_ ? @{$_}[1 .. 3] : map {hex} /(..)(..)(..)/ ]
				} map { @{$_} } @{$table};
				for (@draw) {
					print "<tr><td colspan=$width>", img_egapal(\@imgpal, @{$_});
				}
			}
		}

		say "</table>\n";
	}

	if (my $palette = $info->{list}) {
		my $colours = colorder($palette, $reorder);

		my $rows = 8;
		my $columns = ceil(@{$palette} / $rows);

		say '<table class=color>';
		say sprintf '<caption>%s</caption>', $caption;
		for my $row (0 .. $rows - 1) {
			print '<tr>';
			for my $col (0 .. $columns - 1) {
				my $num = $row + $col * $rows;
				my ($rgb, $name) = split /:/, $colours->[$num], 3;
				$name //= $rgb && $num;
				$name = [ $name, [] ] if $term =~ /^msx/ and !$name;  # no bg for transparency
				$name = [ $name, ['#333'] ] if $term eq 'xkcd';
				print colcell($name, $rgb);
			}
		}

		for (@draw) {
			my $imgpal = colorder($palette,
				$info->{ansiorder} // $palettes->{ $info->{parent} }->{ansiorder}
			);
			print "<tr><td colspan=$columns>", img_egapal($imgpal, @{$_});
		}
		say "</table>\n";
	}
}

sub colorder {
	my ($palette, $reorder) = @_;
	return [ map { $palette->[$_] =~ s/:(?![^:])|$/:$_/r } @{$reorder} ]
		if $reorder;
	return $palette;
}

sub coltable_hsv {
	my ($dim, $rgbval, $greyramp) = @_;

	my $hmax = 2 * $dim * 3;  # each face of the rgb cube
	my $vmax = $dim - 1;
	my $smax = $dim - 1;
	$rgbval ||= sub { join('', @_), map { int $_ * 255 / $vmax } @_ };

	my @greymap = @{$greyramp || []};  # [name, r, g=l, b]
	my @colmap;  # saturation => value => hue => [name, r,g,b]

	for my $r (0 .. $dim - 1) {
		for my $g (0 .. $dim - 1) {
			for my $b (0 .. $dim - 1) {
				my @rgb = ($r, $g, $b);

				my ($h, $s, $v) = Shiar_Sheet::Colour->new(@rgb)->hsv;

				if (!$s) {
					if (@greymap) {
						push @greymap, [ $rgbval->(@rgb) ];
						next;
					}

					$h = 1;  # greyscale hue
					$s = $smax - $v + 1;  # spread brightness over saturation groups
					$v &&= $smax  # highest saturation
						or $v = $s = 1;  # black at initial column
				}

				$h *= $hmax;
				$v = $vmax - $v;
				$s = $smax - $s - $v;

				$colmap[$s][$v][$h] = [ $rgbval->(@rgb) ];
			}
		}
	}

	my $out = '';
	$out .= sprintf '<colgroup span=%d>', scalar @{$_} for @colmap;
	my $huerow = $colmap[0][0]; # first {$_} map { @{$_} } @colmap;
	for my $h (grep { $huerow->[$_] } 0 .. $#{$huerow}) {
		$out .= '<tr>';
		$out .= colcell(@$_) for map { $_->[$h] } map { reverse @{$_} } @colmap;
	}

	if (@greymap) {
		$out .= '<tbody>';
		my $col = 0;
		my $colbreak = scalar map { @$_ } @colmap;  # same width as hue rows
		for my $cell (sort { $a->[1] <=> $b->[1] || $a->[0] <=> $b->[0] } @greymap) {
			$out .= '<tr>' unless $col++ % $colbreak;
			$out .= colcell(@{$cell});
		}
	}

	if (@draw) {
		my @palette = map { [ @{$_}[1 .. 3] ] } @greymap, map {@$_} map {@$_} @colmap;
		my $tablespan = scalar map { @$_ } @colmap;
		my $imgdata = img_egapal(\@palette, @{ $draw[0] });
		$out .= "<tr><td colspan=$tablespan>$imgdata";
	}

	return $out;
}

coltable($_) for @termlist;
:></div>
<hr>

sheet.shiar.nl/source.plp version 1.4 created by Shiar • AGPLv3