#! /usr/bin/env perl

use v5.26;

use strict;
use warnings;
use experimental qw( signatures postderef );

use FindBin '$Bin';

use lib "$Bin/lib";
use lib "$Bin/../lib";

use XrmFFI;
use Config::XrmDatabase::Util qw( parse_resource_name name_arr_to_str );
use JSON::PP;
use Archive::Tar;

srand 1;

use constant NCONFIGS => 1000;
use constant NRECORDS => 750;
use constant NWORDS   => 8;

my $tar = Archive::Tar->new;

my @lc_alphabet = map { chr( $_ + ord( 'a' ) ) } 0 .. 25;
my @uc_alphabet = map { chr( $_ + ord( 'A' ) ) } 0 .. 25;

my @name = @lc_alphabet[ 0 .. NWORDS - 1 ];
my $name = join( q{.}, @name );

my @class = @uc_alphabet[ 0 .. NWORDS - 1 ];
my $class = join( q{.}, @class );

# write a database and the result of querying it with libX11 into the tarball.
# $records is a hash of value => record.
sub add_config ( $file, $records ) {

    my $config = join( "\n", sort( values %$records ), q{} );

    my $db   = XrmFFI->GetStringDatabase( $config );
    my $meta = "${file}.json";
    $db->PutFileDatabase( $file );
    $tar->add_files( $file );
    unlink $file;

    my %res;
    @res{ 'status', 'type', 'value' } = $db->GetResource( $name, $class );

    $tar->add_data(
        $meta,
        encode_json( {
                class => $class,
                name  => $name,
                match => ( defined $res{value} ? $records->{ $res{value} } : undef ),
                res   => \%res,
            } ) );
    say "Wrote $file";
}

for my $config_idx ( 0 .. NCONFIGS ) {

    # create a resource specification

    # iterate through the name.  at each component (except the last) we
    # can choose to:

    # 1. retain the name component

    # 2. use the class component

    # 3. use a single wildcard, '?'

    # 4. use a loose binding, '*', which skips zero or more components.

    my $value = 'value000';

    my %config;
    my %records;

    my @record_idx = ( 0 .. NRECORDS - 1 );

    while ( @record_idx ) {
        my $record_idx = shift @record_idx;

        my @idx = ( 0 .. NWORDS - 2 );
        my @record;

        while ( defined( my $idx = shift @idx ) ) {

            my @prob = sort { $a <=> $b } map { rand } 1 .. 3;

            my $choice = rand;

            if ( $choice < $prob[0] ) {
                push @record, $name[$idx];
            }
            elsif ( $choice < $prob[1] ) {
                push @record, $class[$idx];
            }
            elsif ( $choice < $prob[2] ) {
                push @record, q{?};
            }
            else {
                # skip zero or more of the remaining components
                # (excluding the last, which is always present).
                # skipping zero components means that the current
                # component is still to be processed.
                push @record, q{*};
                unshift @idx, $idx;
                splice( @idx, 0, int( rand( @idx + 1 ) ) );
            }
        }

        my $key = name_arr_to_str( parse_resource_name( join( q{.}, @record, $name[-1] ) ) );

        if ( $records{$key}++ ) {
            unshift @record_idx, $record_idx;
            next;
        }

        ++$value;
        $config{$value} = "$key : $value";
    }

    add_config( sprintf( 'config%03d', $config_idx ), \%config );
}

# explicit checks of loose bindings which match zero components.
# each is a list of resource specifications in a single database.
# databases with a single specification check matching; those with
# more than one check precedence.
my @zero_width = (

    # matching
    ['a*b.c.d.e.f.g.h'],
    ['*a.b.c.d.e.f.g.h'],
    ['a.b.c.d.e.f.g*h'],
    ['a*b*c.d.e.f.g.h'],
    ['a.b.c.d.e.f*g*h'],
    ['*a*b*c*d*e*f*g*h'],
    ['A*B.C.D.E.F.G*H'],
    ['a.b.c.d.e.f*?.h'],
    ['a*?.c.d.e.f.g.h'],

    # should not match
    ['a*a.b.c.d.e.f.g.h'],
    ['a.b.c.d.e.f.g.h*h'],

    # precedence
    [ 'a.b.c.d.e.f.g*h',  'a.b.c.d.e.f.g.h' ],
    [ 'a.b.c.d.e.f.g*h',  'a.b.c.d.e.f.?.h' ],
    [ 'a.b.c.d.e.f.g*h',  'a.b.c.d.e.f*h' ],
    [ 'a*b.c.d.e.f.g.h',  'a.?.c.d.e.f.g.h' ],
    [ 'a*b.c.d.e.f.g.h',  'a.B.c.d.e.f.g.h' ],
    [ '*a.b.c.d.e.f.g.h', 'A.b.c.d.e.f.g.h' ],
);

for my $idx ( keys @zero_width ) {
    my $value = 'value000';
    my %config;
    for my $key ( $zero_width[$idx]->@* ) {
        ++$value;
        $config{$value} = "$key : $value";
    }
    add_config( sprintf( 'config-zero%02d', $idx ), \%config );
}

$tar->write( 't/configs.tgz', 9, );
