#!/usr/bin/perl -w
use strict;

my $esc="\e";
my $lab=0;
my @args=[];
my $rv=0;
my $perm=0;

my $USAGE=<<END;
Usage:
  vtgamma \e[30;1m[-e] [-r] [-l]\e[0m \e[1m<gamma>\e[0m
  vtgamma \e[30;1m[-e] [-r]\e[0m \e[31;1m<\e[0;31mred gamma\e[1m>\e[0m \e[32;1m<\e[0;32mgreen gamma\e[1m>\e[0m \e[1;34m<\e[0;34mblue gamma\e[1m>\e[0m
END
$USAGE=~s/\e\[[0-9;]*m//g unless -t STDERR;

my $PIO_CMAP=0x4B71; # Linux

while(@ARGV)
{
    $_=shift;
    if (/^-e|--escape$/)
    {
        $esc='\e';
    }
    elsif (/^-l|--lab|--Lab|--lchab|--LCHab$/)
    {
        $lab=1;
        require Graphics::ColorObject;
    }
    elsif (/^-r|--reverse$/)
    {
        $rv=1;
    }
    elsif (/^(\d*\.?\d+)$/)
    {
        push @args, $1;
    }
    elsif (/^-p|--permanent$/)
    {
        $^O eq "linux" or die "PIO_CMAP supported only on Linux.\n";
        $perm=1;
    }
    else
    {
        die "Invalid argument: \"$_\"\n$USAGE";
    }
}

my ($r,$g,$b)=
    ($#args==0)? die "$USAGE":
    ($#args==1)? ($args[1],$args[1],$args[1]):
    ($#args==2)? die "Only 2 gammas given, 1 or 3 required.\n":
    ($#args==3)? $lab ? die "Can't give RGB gamma in LCHab mode.\n":
                        ($args[1],$args[2],$args[3]):
    die "Too many gammas given.\n$USAGE";

sub gamma($$)
{
    my ($x,$k)=@_;
    return 0 if $x<=0;
    return ($x>=1)?1:0 if $k<=0;
    return exp(log($x)/$k);
}

sub irgb($$)
{
    my ($c,$bit)=@_;
    return ($c&8?0x55:0) + ($c&$bit?0xaa:0);
}

my %reverse=(0=>15, 15=>0, 7=>8, 8=>7);

sub rgb($)
{
    my ($c)=@_;

    $c=$reverse{$c} if $rv && exists $reverse{$c};

    # basic 16 colors
    return (0xaa, 0x55, 0x00) if $c == 3; # Real CGA/VGA brown.
    return (0xee, 0xdd, 0x00) if $c == 11; # Less white yellow, especially when reversed.
    return (irgb($c,1), irgb($c,2), irgb($c,4)) if $c < 16;

    # 6x6x6 color cube
    if ($c < 232)
    {
        $c -= 16;
        use integer;
        my ($r,$g,$b) = ($c / 36, $c / 6 % 6, $c % 6);
        return ($r ? $r*0x28+0x37:0, $g ? $g*0x28+0x37:0, $b ? $b*0x28+0x37:0);
    }

    # grayscale ramp
    $c = $c*10-2312;
    return ($c, $c, $c);
}

my $setcolor;
my $ncolors=15;
my $out="";
if ($perm)
{
    $setcolor = sub { shift; $out .= sprintf("%c%c%c", @_); };
}
elsif ($ENV{"TERM"}=~/^linux/)
{
    $setcolor = sub { printf "%s]P%1X%02X%02X%02X", $esc, @_; };
}
elsif ($ENV{"TERM"}=~/^hurd/)
{
    # Neither supports nor cleanly ignores.
    die "Hurd console doesn't support palette control, sorry.\n";
}
else
{
    $setcolor = sub { printf "%s]4;%d;rgb:%02x/%02x/%02x%s", $esc, @_,
        $esc eq '\e' ? '\e\\' : "\e\\"; };
    $ncolors=255;
}

for(0..$ncolors)
{
    my @rgb = rgb $_;
    if ($lab)
    {
        my $c=Graphics::ColorObject->new_RGB255(\@rgb);
        my @lab=@{$c->as_LCHab()};
        $lab[0]=100*gamma($lab[0]/100, $r);
        @rgb=@{Graphics::ColorObject->new_LCHab(\@lab)->as_RGB255()};
    }
    else
    {
        $rgb[0]=255*gamma $rgb[0]/255, $r;
        $rgb[1]=255*gamma $rgb[1]/255, $g;
        $rgb[2]=255*gamma $rgb[2]/255, $b;
    }
    $setcolor->($_, @rgb);
}

if ($perm)
{
    ioctl(STDOUT,$PIO_CMAP,$out)
        or die "$0: PIO_CMAP failed: $^E\n";
}
else
{
    print "\n" if $esc ne "\e";
}
